diff options
Diffstat (limited to 'lib/Tie/File')
38 files changed, 0 insertions, 6332 deletions
diff --git a/lib/Tie/File/t/00_version.t b/lib/Tie/File/t/00_version.t deleted file mode 100644 index f98523a0e1..0000000000 --- a/lib/Tie/File/t/00_version.t +++ /dev/null @@ -1,22 +0,0 @@ -#!/usr/bin/perl - -print "1..1\n"; - -my $testversion = "0.97_01"; -use Tie::File; - -if ($Tie::File::VERSION != $testversion) { - print STDERR " - -*** WHOA THERE!!! *** - -You seem to be running version $Tie::File::VERSION of the module -against version $testversion of the test suite! - -None of the other test results will be reliable. -"; - exit 1; -} - -print "ok 1\n"; - diff --git a/lib/Tie/File/t/01_gen.t b/lib/Tie/File/t/01_gen.t deleted file mode 100644 index 202b09c76a..0000000000 --- a/lib/Tie/File/t/01_gen.t +++ /dev/null @@ -1,165 +0,0 @@ -#!/usr/bin/perl - -$| = 1; -my $file = "tf$$.txt"; -1 while unlink $file; - -print "1..75\n"; - -my $N = 1; -use Tie::File; -print "ok $N\n"; $N++; - -my $o = tie @a, 'Tie::File', $file, autochomp => 0, autodefer => 0; -print $o ? "ok $N\n" : "not ok $N\n"; -$N++; - -$: = $o->{recsep}; - -# 3-5 create -$a[0] = 'rec0'; -check_contents("rec0"); - -# 6-11 append -$a[1] = 'rec1'; -check_contents("rec0", "rec1"); -$a[2] = 'rec2'; -check_contents("rec0", "rec1", "rec2"); - -# 12-20 same-length alterations -$a[0] = 'new0'; -check_contents("new0", "rec1", "rec2"); -$a[1] = 'new1'; -check_contents("new0", "new1", "rec2"); -$a[2] = 'new2'; -check_contents("new0", "new1", "new2"); - -# 21-35 lengthening alterations -$a[0] = 'long0'; -check_contents("long0", "new1", "new2"); -$a[1] = 'long1'; -check_contents("long0", "long1", "new2"); -$a[2] = 'long2'; -check_contents("long0", "long1", "long2"); -$a[1] = 'longer1'; -check_contents("long0", "longer1", "long2"); -$a[0] = 'longer0'; -check_contents("longer0", "longer1", "long2"); - -# 36-50 shortening alterations, including truncation -$a[0] = 'short0'; -check_contents("short0", "longer1", "long2"); -$a[1] = 'short1'; -check_contents("short0", "short1", "long2"); -$a[2] = 'short2'; -check_contents("short0", "short1", "short2"); -$a[1] = 'sh1'; -check_contents("short0", "sh1", "short2"); -$a[0] = 'sh0'; -check_contents("sh0", "sh1", "short2"); - -# (51-56) file with holes -$a[4] = 'rec4'; -check_contents("sh0", "sh1", "short2", "", "rec4"); -$a[3] = 'rec3'; -check_contents("sh0", "sh1", "short2", "rec3", "rec4"); - -# (57-59) zero out file -@a = (); -check_contents(); - -# (60-62) insert into the middle of an empty file -$a[3] = "rec3"; -check_contents("", "", "", "rec3"); - -# (63-68) 20020326 You thought there would be a bug in STORE where if -# a cached record was false, STORE wouldn't see it at all. But you -# forgot that records always come back from the cache with the record -# separator attached, so they are unlikely to be false. The only -# really weird case is when the cached record is empty and the record -# separator is "0". Test that in 09_gen_rs.t. -$a[1] = "0"; -check_contents("", "0", "", "rec3"); -$a[1] = "whoops"; -check_contents("", "whoops", "", "rec3"); - -# (69-72) make sure that undefs are treated correctly---they should -# be converted to empty records, and should not raise any warnings. -# (Some of these failed in 0.90. The change to _fixrec fixed them.) -# 20020331 -{ - my $good = 1; my $warn; - # If any of these raise warnings, we have a problem. - local $SIG{__WARN__} = sub { $good = 0; $warn = shift(); ctrlfix($warn)}; - local $^W = 1; - @a = (1); - $a[0] = undef; - print $good ? "ok $N\n" : "not ok $N # $warn\n"; - $N++; $good = 1; - print defined($a[0]) ? "ok $N\n" : "not ok $N\n"; - $N++; $good = 1; - $a[3] = '3'; - print defined($a[1]) ? "ok $N\n" : "not ok $N\n"; - $N++; $good = 1; - undef $a[3]; - print $good ? "ok $N\n" : "not ok $N # $warn\n"; - $N++; $good = 1; -} - -# (73-75) What if the user has tampered with $\ ? -{ { local $\ = "stop messing with the funny variables!"; - @a = (0..2); - } - check_contents(0..2); -} - -use POSIX 'SEEK_SET'; -sub check_contents { - my @c = @_; - my $x = join $:, @c, ''; - local *FH = $o->{fh}; - seek FH, 0, SEEK_SET; -# my $open = open FH, "< $file"; - my $a; - { local $/; $a = <FH> } - $a = "" unless defined $a; - if ($a eq $x) { - print "ok $N\n"; - } else { - ctrlfix($a, $x); - print "not ok $N\n# expected <$x>, got <$a>\n"; - } - $N++; - - # now check FETCH: - my $good = 1; - my $msg; - for (0.. $#c) { - my $aa = $a[$_]; - unless ($aa eq "$c[$_]$:") { - $msg = "expected <$c[$_]$:>, got <$aa>"; - ctrlfix($msg); - $good = 0; - } - } - print $good ? "ok $N\n" : "not ok $N # $msg\n"; - $N++; - - print $o->_check_integrity($file, $ENV{INTEGRITY}) - ? "ok $N\n" : "not ok $N\n"; - $N++; -} - -sub ctrlfix { - for (@_) { - s/\n/\\n/g; - s/\r/\\r/g; - } -} - -END { - undef $o; - untie @a; - 1 while unlink $file; -} - diff --git a/lib/Tie/File/t/02_fetchsize.t b/lib/Tie/File/t/02_fetchsize.t deleted file mode 100644 index 12d2b51cba..0000000000 --- a/lib/Tie/File/t/02_fetchsize.t +++ /dev/null @@ -1,53 +0,0 @@ -#!/usr/bin/perl - -my $file = "tf$$.txt"; -$: = Tie::File::_default_recsep(); -my $data = "rec1$:rec2$:rec3$:"; - -print "1..6\n"; - -my $N = 1; -use Tie::File; -print "ok $N\n"; $N++; - -open F, "> $file" or die $!; -binmode F; -print F $data; -close F; - - -my $o = tie @a, 'Tie::File', $file, autochomp => 0; -print $o ? "ok $N\n" : "not ok $N\n"; -$N++; - -$: = $o->{recsep}; - -my $n; - -# 3 test array element count -$n = @a; -print $n == 3 ? "ok $N\n" : "not ok $N # n=$n\n"; -$N++; - -# 4 same thing again -$n = @a; -print $n == 3 ? "ok $N\n" : "not ok $N # n=$n\n"; -$N++; - -# 5 test $#a notation -$n = $#a; -print $n == 2 ? "ok $N\n" : "not ok $N # n=$n\n"; -$N++; - -# 6 test looping over array elements -my $q; -for (@a) { $q .= $_ } -print $q eq $data ? "ok $N\n" : "not ok $N # n=$n\n"; -$N++; - -END { - undef $o; - untie @a; - 1 while unlink $file; -} - diff --git a/lib/Tie/File/t/03_longfetch.t b/lib/Tie/File/t/03_longfetch.t deleted file mode 100644 index 7d5a3886fe..0000000000 --- a/lib/Tie/File/t/03_longfetch.t +++ /dev/null @@ -1,54 +0,0 @@ -#!/usr/bin/perl -# -# Make sure we can fetch a record in the middle of the file -# before we've ever looked at any records before it -# -# Make sure fetching past the end of the file returns the undefined value -# -# (tests _fill_offsets_to() ) -# - -my $file = "tf$$.txt"; -$: = Tie::File::_default_recsep(); -my $data = "rec0$:rec1$:rec2$:"; - -print "1..8\n"; - -my $N = 1; -use Tie::File; -print "ok $N\n"; $N++; - -open F, "> $file" or die $!; -binmode F; -print F $data; -close F; - - -my $o = tie @a, 'Tie::File', $file, autochomp => 0; -print $o ? "ok $N\n" : "not ok $N\n"; -$N++; - -$: = $o->{recsep}; - -my $n; - -# 3-5 -for (2, 1, 0) { - my $rec = $a[$_]; - print $rec eq "rec$_$:" ? "ok $N\n" : "not ok $N # rec=<$rec> ?\n"; - $N++; -} - -# 6-8 -for (3, 4, 6) { - my $rec = $a[$_]; - print ((not defined $rec) ? "ok $N\n" : "not ok $N # rec=<$rec> is defined\n"); - $N++; -} - -END { - undef $o; - untie @a; - 1 while unlink $file; -} - diff --git a/lib/Tie/File/t/04_splice.t b/lib/Tie/File/t/04_splice.t deleted file mode 100644 index b3880b758c..0000000000 --- a/lib/Tie/File/t/04_splice.t +++ /dev/null @@ -1,264 +0,0 @@ -#!/usr/bin/perl - -# -# Check SPLICE function's effect on the file -# (07_rv_splice.t checks its return value) -# -# Each call to 'check_contents' actually performs two tests. -# First, it calls the tied object's own 'check_integrity' method, -# which makes sure that the contents of the read cache and offset tables -# accurately reflect the contents of the file. -# Then, it checks the actual contents of the file against the expected -# contents. - - -$| = 1; -my $file = "tf$$.txt"; -$: = Tie::File::_default_recsep(); -my $data = "rec0$:rec1$:rec2$:"; -print "1..118\n"; - -init_file($data); - -my $N = 1; -use Tie::File; -print "ok $N\n"; $N++; # partial credit just for showing up - -my $o = tie @a, 'Tie::File', $file; -print $o ? "ok $N\n" : "not ok $N\n"; -$N++; - -$: = $o->{recsep}; -my $n; - -# (3-22) splicing at the beginning -splice(@a, 0, 0, "rec4"); -check_contents("rec4$:$data"); -splice(@a, 0, 1, "rec5"); # same length -check_contents("rec5$:$data"); -splice(@a, 0, 1, "record5"); # longer -check_contents("record5$:$data"); - -splice(@a, 0, 1, "r5"); # shorter -check_contents("r5$:$data"); -splice(@a, 0, 1); # removal -check_contents("$data"); -splice(@a, 0, 0); # no-op -check_contents("$data"); -splice(@a, 0, 0, 'r7', 'rec8'); # insert more than one -check_contents("r7$:rec8$:$data"); -splice(@a, 0, 2, 'rec7', 'record8', 'rec9'); # insert more than delete -check_contents("rec7$:record8$:rec9$:$data"); - -splice(@a, 0, 3, 'record9', 'rec10'); # delete more than insert -check_contents("record9$:rec10$:$data"); -splice(@a, 0, 2); # delete more than one -check_contents("$data"); - - -# (23-42) splicing in the middle -splice(@a, 1, 0, "rec4"); -check_contents("rec0$:rec4$:rec1$:rec2$:"); -splice(@a, 1, 1, "rec5"); # same length -check_contents("rec0$:rec5$:rec1$:rec2$:"); -splice(@a, 1, 1, "record5"); # longer -check_contents("rec0$:record5$:rec1$:rec2$:"); - -splice(@a, 1, 1, "r5"); # shorter -check_contents("rec0$:r5$:rec1$:rec2$:"); -splice(@a, 1, 1); # removal -check_contents("$data"); -splice(@a, 1, 0); # no-op -check_contents("$data"); -splice(@a, 1, 0, 'r7', 'rec8'); # insert more than one -check_contents("rec0$:r7$:rec8$:rec1$:rec2$:"); -splice(@a, 1, 2, 'rec7', 'record8', 'rec9'); # insert more than delete -check_contents("rec0$:rec7$:record8$:rec9$:rec1$:rec2$:"); - -splice(@a, 1, 3, 'record9', 'rec10'); # delete more than insert -check_contents("rec0$:record9$:rec10$:rec1$:rec2$:"); -splice(@a, 1, 2); # delete more than one -check_contents("$data"); - -# (43-62) splicing at the end -splice(@a, 3, 0, "rec4"); -check_contents("$ {data}rec4$:"); -splice(@a, 3, 1, "rec5"); # same length -check_contents("$ {data}rec5$:"); -splice(@a, 3, 1, "record5"); # longer -check_contents("$ {data}record5$:"); - -splice(@a, 3, 1, "r5"); # shorter -check_contents("$ {data}r5$:"); -splice(@a, 3, 1); # removal -check_contents("$data"); -splice(@a, 3, 0); # no-op -check_contents("$data"); -splice(@a, 3, 0, 'r7', 'rec8'); # insert more than one -check_contents("$ {data}r7$:rec8$:"); -splice(@a, 3, 2, 'rec7', 'record8', 'rec9'); # insert more than delete -check_contents("$ {data}rec7$:record8$:rec9$:"); - -splice(@a, 3, 3, 'record9', 'rec10'); # delete more than insert -check_contents("$ {data}record9$:rec10$:"); -splice(@a, 3, 2); # delete more than one -check_contents("$data"); - -# (63-82) splicing with negative subscript -splice(@a, -1, 0, "rec4"); -check_contents("rec0$:rec1$:rec4$:rec2$:"); -splice(@a, -1, 1, "rec5"); # same length -check_contents("rec0$:rec1$:rec4$:rec5$:"); -splice(@a, -1, 1, "record5"); # longer -check_contents("rec0$:rec1$:rec4$:record5$:"); - -splice(@a, -1, 1, "r5"); # shorter -check_contents("rec0$:rec1$:rec4$:r5$:"); -splice(@a, -1, 1); # removal -check_contents("rec0$:rec1$:rec4$:"); -splice(@a, -1, 0); # no-op -check_contents("rec0$:rec1$:rec4$:"); -splice(@a, -1, 0, 'r7', 'rec8'); # insert more than one -check_contents("rec0$:rec1$:r7$:rec8$:rec4$:"); -splice(@a, -1, 2, 'rec7', 'record8', 'rec9'); # insert more than delete -check_contents("rec0$:rec1$:r7$:rec8$:rec7$:record8$:rec9$:"); - -splice(@a, -3, 3, 'record9', 'rec10'); # delete more than insert -check_contents("rec0$:rec1$:r7$:rec8$:record9$:rec10$:"); -splice(@a, -4, 3); # delete more than one -check_contents("rec0$:rec1$:rec10$:"); - -# (83-84) scrub it all out -splice(@a, 0, 3); -check_contents(""); - -# (85-86) put some back in -splice(@a, 0, 0, "rec0", "rec1"); -check_contents("rec0$:rec1$:"); - -# (87-88) what if we remove too many records? -splice(@a, 0, 17); -check_contents(""); - -# (89-92) In the past, splicing past the end was not correctly detected -# (1.14) -splice(@a, 89, 3); -check_contents(""); -splice(@a, @a, 3); -check_contents(""); - -# (93-96) Also we did not emulate splice's freaky behavior when inserting -# past the end of the array (1.14) -splice(@a, 89, 0, "I", "like", "pie"); -check_contents("I$:like$:pie$:"); -splice(@a, 89, 0, "pie pie pie"); -check_contents("I$:like$:pie$:pie pie pie$:"); - -# (97) Splicing with too large a negative number should be fatal -# This test ignored because it causes 5.6.1 and 5.7.3 to dump core -# It also garbles the stack under 5.005_03 (20020401) -# NOT MY FAULT -if ($] > 5.007003) { - eval { splice(@a, -7, 0) }; - print $@ =~ /^Modification of non-creatable array value attempted, subscript -7/ - ? "ok $N\n" : "not ok $N \# \$\@ was '$@'\n"; -} else { - print "ok $N \# skipped (versions through 5.7.3 dump core here.)\n"; -} -$N++; - -# (98-101) Test default arguments -splice @a, 0, 0, (0..11); -splice @a, 4; -check_contents("0$:1$:2$:3$:"); -splice @a; -check_contents(""); - -# (102-103) I think there's a bug here---it will fail to clear the EOF flag -@a = (0..11); -splice @a, -1, 1000; -check_contents("0$:1$:2$:3$:4$:5$:6$:7$:8$:9$:10$:"); - -# (104-106) make sure that undefs are treated correctly---they should -# be converted to empty records, and should not raise any warnings. -# (Some of these failed in 0.90. The change to _fixrec fixed them.) -# 20020331 -{ - my $good = 1; my $warn; - # If any of these raise warnings, we have a problem. - local $SIG{__WARN__} = sub { $good = 0; $warn = shift(); ctrlfix($warn)}; - local $^W = 1; - @a = (1); - splice @a, 1, 0, undef, undef, undef; - print $good ? "ok $N\n" : "not ok $N # $warn\n"; - $N++; $good = 1; - print defined($a[2]) ? "ok $N\n" : "not ok $N\n"; - $N++; $good = 1; - my @r = splice @a, 2; - print defined($r[0]) ? "ok $N\n" : "not ok $N\n"; - $N++; $good = 1; -} - -# (107-118) splice with negative length was treated wrong -# 20020402 Reported by Juerd Waalboer -@a = (0..8) ; -splice @a, 0, -3; -check_contents("6$:7$:8$:"); -@a = (0..8) ; -splice @a, 1, -3; -check_contents("0$:6$:7$:8$:"); -@a = (0..8) ; -splice @a, 7, -3; -check_contents("0$:1$:2$:3$:4$:5$:6$:7$:8$:"); -@a = (0..2) ; -splice @a, 0, -3; -check_contents("0$:1$:2$:"); -@a = (0..2) ; -splice @a, 1, -3; -check_contents("0$:1$:2$:"); -@a = (0..2) ; -splice @a, 7, -3; -check_contents("0$:1$:2$:"); - -sub init_file { - my $data = shift; - open F, "> $file" or die $!; - binmode F; - print F $data; - close F; -} - -use POSIX 'SEEK_SET'; -sub check_contents { - my $x = shift; - my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY}); - local *FH = $o->{fh}; - seek FH, 0, SEEK_SET; - print $integrity ? "ok $N\n" : "not ok $N\n"; - $N++; - my $a; - { local $/; $a = <FH> } - $a = "" unless defined $a; - if ($a eq $x) { - print "ok $N\n"; - } else { - ctrlfix($a, $x); - print "not ok $N\n# expected <$x>, got <$a>\n"; - } - $N++; -} - - -sub ctrlfix { - for (@_) { - s/\n/\\n/g; - s/\r/\\r/g; - } -} - -END { - undef $o; - untie @a; - 1 while unlink $file; -} - diff --git a/lib/Tie/File/t/05_size.t b/lib/Tie/File/t/05_size.t deleted file mode 100644 index 44c69f910f..0000000000 --- a/lib/Tie/File/t/05_size.t +++ /dev/null @@ -1,129 +0,0 @@ -#!/usr/bin/perl -# -# Check FETCHSIZE and SETSIZE functions -# PUSH POP SHIFT UNSHIFT -# - -use POSIX 'SEEK_SET'; - -my $file = "tf$$.txt"; -my ($o, $n); - -print "1..16\n"; - -my $N = 1; -use Tie::File; -print "ok $N\n"; $N++; - -# 2-3 FETCHSIZE 0-length file -open F, "> $file" or die $!; -binmode F; -close F; -$o = tie @a, 'Tie::File', $file; -print $o ? "ok $N\n" : "not ok $N\n"; -$N++; - -$: = $o->{recsep}; - -$n = @a; -print $n == 0 ? "ok $N\n" : "not ok $N # $n, s/b 0\n"; -$N++; - -# Reset everything -undef $o; -untie @a; - -my $data = "rec0$:rec1$:rec2$:"; -open F, "> $file" or die $!; -binmode F; -print F $data; -close F; - -$o = tie @a, 'Tie::File', $file; -print $o ? "ok $N\n" : "not ok $N\n"; -$N++; - -# 4-5 FETCHSIZE positive-length file -$n = @a; -print $n == 3 ? "ok $N\n" : "not ok $N # $n, s/b 0\n"; -$N++; - -# STORESIZE -# (6-7) Make it longer: -populate(); -$#a = 4; -check_contents("$data$:$:"); - -# (8-9) Make it longer again: -populate(); -$#a = 6; -check_contents("$data$:$:$:$:"); - -# (10-11) Make it shorter: -populate(); -$#a = 4; -check_contents("$data$:$:"); - -# (12-13) Make it shorter again: -populate(); -$#a = 2; -check_contents($data); - -# (14-15) Get rid of it completely: -populate(); -$#a = -1; -check_contents(''); - -# (16) 20020324 I have an idea that shortening the array will not -# expunge a cached record at the end if one is present. -$o->defer; -$a[3] = "record"; -my $r = $a[3]; -$#a = -1; -$r = $a[3]; -print (! defined $r ? "ok $N\n" : "not ok $N \# was <$r>; should be UNDEF\n"); -# Turns out not to be the case---STORESIZE explicitly removes them later -# 20020326 Well, but happily, this test did fail today. - -# In the past, there was a bug in STORESIZE that it didn't correctly -# remove deleted records from the cache. This wasn't detected -# because these tests were all done with an empty cache. populate() -# will ensure that the cache is fully populated. -sub populate { - my $z; - $z = $a[$_] for 0 .. $#a; -} - -sub check_contents { - my $x = shift; - local *FH = $o->{fh}; - seek FH, 0, SEEK_SET; - my $a; - { local $/; $a = <FH> } - $a = "" unless defined $a; - if ($a eq $x) { - print "ok $N\n"; - } else { - ctrlfix($a, $x); - print "not ok $N\n# expected <$x>, got <$a>\n"; - } - $N++; - my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY}); - print $integrity ? "ok $N\n" : "not ok $N \# integrity\n"; - $N++; -} - - -sub ctrlfix { - for (@_) { - s/\n/\\n/g; - s/\r/\\r/g; - } -} - -END { - undef $o; - untie @a; - 1 while unlink $file; -} - diff --git a/lib/Tie/File/t/06_fixrec.t b/lib/Tie/File/t/06_fixrec.t deleted file mode 100644 index bf24be1300..0000000000 --- a/lib/Tie/File/t/06_fixrec.t +++ /dev/null @@ -1,53 +0,0 @@ -#!/usr/bin/perl - -use POSIX 'SEEK_SET'; -my $file = "tf$$.txt"; -$: = Tie::File::_default_recsep(); - -print "1..5\n"; - -my $N = 1; -use Tie::File; -print "ok $N\n"; $N++; - -my $o = tie @a, 'Tie::File', $file, autodefer => 0; -print $o ? "ok $N\n" : "not ok $N\n"; -$N++; - -$a[0] = 'rec0'; -check_contents("rec0$:"); -$a[1] = "rec1$:"; -check_contents("rec0$:rec1$:"); -$a[2] = "rec2$:$:"; # should we detect this? -check_contents("rec0$:rec1$:rec2$:$:"); - -sub check_contents { - my $x = shift; - local *FH = $o->{fh}; - seek FH, 0, SEEK_SET; - my $a; - { local $/; $a = <FH> } - $a = "" unless defined $a; - if ($a eq $x) { - print "ok $N\n"; - } else { - my $msg = "not ok $N # expected <$x>, got <$a>"; - ctrlfix($msg); - print "$msg\n"; - } - $N++; -} - -sub ctrlfix { - for (@_) { - s/\n/\\n/g; - s/\r/\\r/g; - } -} - -END { - undef $o; - untie @a; - 1 while unlink $file; -} - diff --git a/lib/Tie/File/t/07_rv_splice.t b/lib/Tie/File/t/07_rv_splice.t deleted file mode 100644 index e5c09b1a48..0000000000 --- a/lib/Tie/File/t/07_rv_splice.t +++ /dev/null @@ -1,205 +0,0 @@ -#!/usr/bin/perl -# -# Check SPLICE function's return value -# (04_splice.t checks its effect on the file) -# - - -my $file = "tf$$.txt"; -$: = Tie::File::_default_recsep(); -my $data = "rec0$:rec1$:rec2$:"; - -print "1..56\n"; - -my $N = 1; -use Tie::File; -print "ok $N\n"; $N++; # partial credit just for showing up - -init_file($data); - -my $o = tie @a, 'Tie::File', $file, autochomp => 0; -print $o ? "ok $N\n" : "not ok $N\n"; -$N++; - -my $n; - -# (3-12) splicing at the beginning -@r = splice(@a, 0, 0, "rec4"); -check_result(); -@r = splice(@a, 0, 1, "rec5"); # same length -check_result("rec4"); -@r = splice(@a, 0, 1, "record5"); # longer -check_result("rec5"); - -@r = splice(@a, 0, 1, "r5"); # shorter -check_result("record5"); -@r = splice(@a, 0, 1); # removal -check_result("r5"); -@r = splice(@a, 0, 0); # no-op -check_result(); -@r = splice(@a, 0, 0, 'r7', 'rec8'); # insert more than one -check_result(); -@r = splice(@a, 0, 2, 'rec7', 'record8', 'rec9'); # insert more than delete -check_result('r7', 'rec8'); - -@r = splice(@a, 0, 3, 'record9', 'rec10'); # delete more than insert -check_result('rec7', 'record8', 'rec9'); -@r = splice(@a, 0, 2); # delete more than one -check_result('record9', 'rec10'); - - -# (13-22) splicing in the middle -@r = splice(@a, 1, 0, "rec4"); -check_result(); -@r = splice(@a, 1, 1, "rec5"); # same length -check_result('rec4'); -@r = splice(@a, 1, 1, "record5"); # longer -check_result('rec5'); - -@r = splice(@a, 1, 1, "r5"); # shorter -check_result("record5"); -@r = splice(@a, 1, 1); # removal -check_result("r5"); -@r = splice(@a, 1, 0); # no-op -check_result(); -@r = splice(@a, 1, 0, 'r7', 'rec8'); # insert more than one -check_result(); -@r = splice(@a, 1, 2, 'rec7', 'record8', 'rec9'); # insert more than delete -check_result('r7', 'rec8'); - -@r = splice(@a, 1, 3, 'record9', 'rec10'); # delete more than insert -check_result('rec7', 'record8', 'rec9'); -@r = splice(@a, 1, 2); # delete more than one -check_result('record9','rec10'); - -# (23-32) splicing at the end -@r = splice(@a, 3, 0, "rec4"); -check_result(); -@r = splice(@a, 3, 1, "rec5"); # same length -check_result('rec4'); -@r = splice(@a, 3, 1, "record5"); # longer -check_result('rec5'); - -@r = splice(@a, 3, 1, "r5"); # shorter -check_result('record5'); -@r = splice(@a, 3, 1); # removal -check_result('r5'); -@r = splice(@a, 3, 0); # no-op -check_result(); -@r = splice(@a, 3, 0, 'r7', 'rec8'); # insert more than one -check_result(); -@r = splice(@a, 3, 2, 'rec7', 'record8', 'rec9'); # insert more than delete -check_result('r7', 'rec8'); - -@r = splice(@a, 3, 3, 'record9', 'rec10'); # delete more than insert -check_result('rec7', 'record8', 'rec9'); -@r = splice(@a, 3, 2); # delete more than one -check_result('record9', 'rec10'); - -# (33-42) splicing with negative subscript -@r = splice(@a, -1, 0, "rec4"); -check_result(); -@r = splice(@a, -1, 1, "rec5"); # same length -check_result('rec2'); -@r = splice(@a, -1, 1, "record5"); # longer -check_result("rec5"); - -@r = splice(@a, -1, 1, "r5"); # shorter -check_result("record5"); -@r = splice(@a, -1, 1); # removal -check_result("r5"); -@r = splice(@a, -1, 0); # no-op -check_result(); -@r = splice(@a, -1, 0, 'r7', 'rec8'); # insert more than one -check_result(); -@r = splice(@a, -1, 2, 'rec7', 'record8', 'rec9'); # insert more than delete -check_result('rec4'); - -@r = splice(@a, -3, 3, 'record9', 'rec10'); # delete more than insert -check_result('rec7', 'record8', 'rec9'); -@r = splice(@a, -4, 3); # delete more than one -check_result('r7', 'rec8', 'record9'); - -# (43) scrub it all out -@r = splice(@a, 0, 3); -check_result('rec0', 'rec1', 'rec10'); - -# (44) put some back in -@r = splice(@a, 0, 0, "rec0", "rec1"); -check_result(); - -# (45) what if we remove too many records? -@r = splice(@a, 0, 17); -check_result('rec0', 'rec1'); - -# (46-48) Now check the scalar context return -splice(@a, 0, 0, qw(I like pie)); -my $r; -$r = splice(@a, 0, 0); -print !defined($r) ? "ok $N\n" : "not ok $N \# return should have been undef, was <$r>\n"; -$N++; - -$r = splice(@a, 2, 1); -print $r eq "pie$:" ? "ok $N\n" : "not ok $N \# return should have been 'pie\\n', was <$r>\n"; -$N++; - -$r = splice(@a, 0, 2); -print $r eq "like$:" ? "ok $N\n" : "not ok $N \# return should have been 'like\\n', was <$r>\n"; -$N++; - -# (49-50) Test default arguments -splice @a, 0, 0, (0..11); -@r = splice @a, 4; -check_result(4..11); -@r = splice @a; -check_result(0..3); - -# (51-56) splice with negative length was treated wrong -# 20020402 Reported by Juerd Waalboer -@a = (0..8) ; -@r = splice @a, 0, -3; -check_result(0..5); -@a = (0..8) ; -@r = splice @a, 1, -3; -check_result(1..5); -@a = (0..8) ; -@r = splice @a, 7, -3; -check_result(); -@a = (0..2) ; -@r = splice @a, 0, -3; -check_result(); -@a = (0..2) ; -@r = splice @a, 1, -3; -check_result(); -@a = (0..2) ; -@r = splice @a, 7, -3; -check_result(); - -sub init_file { - my $data = shift; - open F, "> $file" or die $!; - binmode F; - print F $data; - close F; -} - -# actual results are in @r. -# expected results are in @_ -sub check_result { - my @x = @_; - s/$:$// for @r; - my $good = 1; - $good = 0 unless @r == @x; - for my $i (0 .. $#r) { - $good = 0 unless $r[$i] eq $x[$i]; - } - print $good ? "ok $N\n" : "not ok $N \# was (@r); should be (@x)\n"; - $N++; -} - -END { - undef $o; - untie @a; - 1 while unlink $file; -} - diff --git a/lib/Tie/File/t/08_ro.t b/lib/Tie/File/t/08_ro.t deleted file mode 100644 index 5fd8933bf8..0000000000 --- a/lib/Tie/File/t/08_ro.t +++ /dev/null @@ -1,86 +0,0 @@ -#!/usr/bin/perl -# -# Make sure it works to open the file in read-only mode -# - -my $file = "tf$$.txt"; -$: = Tie::File::_default_recsep(); - -print "1..13\n"; - -my $N = 1; -use Tie::File; -use Fcntl 'O_RDONLY'; -print "ok $N\n"; $N++; - -my @items = qw(Gold Frankincense Myrrh Ivory Apes Peacocks); -init_file(join $:, @items, ''); - -my $o = tie @a, 'Tie::File', $file, mode => O_RDONLY, autochomp => 0; -print $o ? "ok $N\n" : "not ok $N\n"; -$N++; - -$#a == $#items ? print "ok $N\n" : print "not ok $N\n"; -$N++; - -for my $i (0..$#items) { - ("$items[$i]$:" eq $a[$i]) ? print "ok $N\n" : print "not ok $N\n"; - $N++; -} - -sub init_file { - my $data = shift; - open F, "> $file" or die $!; - binmode F; - print F $data; - close F; -} - -undef $o; untie @a; -my $badrec = "Malformed"; -# (10-13) When a record lacks the record seprator, we sneakily try -# to fix it. How does that work when the file is read-only? -if (setup_badly_terminated_file(4)) { - my $good = 1; - my $warn; - local $SIG{__WARN__} = sub { $good = 0; ctrlfix($warn = shift); }; - local $^W = 1; - my $o = tie @a, 'Tie::File', $file, mode => O_RDONLY, autochomp => 0 - or die "Couldn't tie $file: $!"; - - print $a[0] eq "Malformed$:" ? "ok $N\n" : "not ok $N\n"; $N++; - print $good ? "ok $N\n" : "not ok $N # $warn\n"; $good = 1; $N++; - print $a[0] eq "Malformed$:" ? "ok $N\n" : "not ok $N\n"; $N++; - print $good ? "ok $N\n" : "not ok $N # $warn\n"; $good = 1; $N++; -} - -sub setup_badly_terminated_file { - my $NTESTS = shift; - open F, "> $file" or die "Couldn't open $file: $!"; - binmode F; - print F $badrec; - close F; - unless (-s $file == length $badrec) { - for (1 .. $NTESTS) { - print "ok $N \# skipped - can't create improperly terminated file\n"; - $N++; - } - return; - } - return 1; -} - - -sub ctrlfix { - for (@_) { - s/\n/\\n/g; - s/\r/\\r/g; - } -} - -END { - undef $o; - untie @a; - 1 while unlink $file; -} - diff --git a/lib/Tie/File/t/09_gen_rs.t b/lib/Tie/File/t/09_gen_rs.t deleted file mode 100644 index e590210335..0000000000 --- a/lib/Tie/File/t/09_gen_rs.t +++ /dev/null @@ -1,225 +0,0 @@ -#!/usr/bin/perl - -my $file = "tf$$.txt"; - -print "1..59\n"; - -use Fcntl 'O_RDONLY'; - -my $N = 1; -use Tie::File; -print "ok $N\n"; $N++; - -$RECSEP = 'blah'; -my $o = tie @a, 'Tie::File', $file, - recsep => $RECSEP, autochomp => 0, autodefer => 0; -print $o ? "ok $N\n" : "not ok $N\n"; -$N++; - - -# 3-4 create -$a[0] = 'rec0'; -check_contents("rec0"); - -# 5-8 append -$a[1] = 'rec1'; -check_contents("rec0", "rec1"); -$a[2] = 'rec2'; -check_contents("rec0", "rec1", "rec2"); - -# 9-14 same-length alterations -$a[0] = 'new0'; -check_contents("new0", "rec1", "rec2"); -$a[1] = 'new1'; -check_contents("new0", "new1", "rec2"); -$a[2] = 'new2'; -check_contents("new0", "new1", "new2"); - -# 15-24 lengthening alterations -$a[0] = 'long0'; -check_contents("long0", "new1", "new2"); -$a[1] = 'long1'; -check_contents("long0", "long1", "new2"); -$a[2] = 'long2'; -check_contents("long0", "long1", "long2"); -$a[1] = 'longer1'; -check_contents("long0", "longer1", "long2"); -$a[0] = 'longer0'; -check_contents("longer0", "longer1", "long2"); - -# 25-34 shortening alterations, including truncation -$a[0] = 'short0'; -check_contents("short0", "longer1", "long2"); -$a[1] = 'short1'; -check_contents("short0", "short1", "long2"); -$a[2] = 'short2'; -check_contents("short0", "short1", "short2"); -$a[1] = 'sh1'; -check_contents("short0", "sh1", "short2"); -$a[0] = 'sh0'; -check_contents("sh0", "sh1", "short2"); - -# (35-38) file with holes -$a[4] = 'rec4'; -check_contents("sh0", "sh1", "short2", "", "rec4"); -$a[3] = 'rec3'; -check_contents("sh0", "sh1", "short2", "rec3", "rec4"); - -# (39-40) zero out file -@a = (); -check_contents(); - -# (41-42) insert into the middle of an empty file -$a[3] = "rec3"; -check_contents("", "", "", "rec3"); - -# (43-47) 20020326 You thought there would be a bug in STORE where if -# a cached record was false, STORE wouldn't see it at all. Yup, there is, -# and adding the appropriate defined() test fixes the problem. -undef $o; untie @a; 1 while unlink $file; -$RECSEP = '0'; -$o = tie @a, 'Tie::File', $file, - recsep => $RECSEP, autochomp => 0, autodefer => 0; -print $o ? "ok $N\n" : "not ok $N\n"; -$N++; -$#a = 2; -my $z = $a[1]; # caches "0" -$a[2] = "oops"; -check_contents("", "", "oops"); -$a[1] = "bah"; -check_contents("", "bah", "oops"); -undef $o; untie @a; - -# (48-56) 20020331 Make sure we correctly handle the case where the final -# record of the file is not properly terminated, Through version 0.90, -# we would mangle the file. -my $badrec = "Malformed"; -$: = $RECSEP = Tie::File::_default_recsep(); -# (48-50) -if (setup_badly_terminated_file(3)) { - $o = tie @a, 'Tie::File', $file, - recsep => $RECSEP, autochomp => 0, autodefer => 0 - or die "Couldn't tie file: $!"; - my $z = $a[0]; - print $z eq "$badrec$:" ? "ok $N\n" : - "not ok $N \# got $z, expected $badrec\n"; - $N++; - push @a, "next"; - check_contents($badrec, "next"); -} -# (51-52) -if (setup_badly_terminated_file(2)) { - $o = tie @a, 'Tie::File', $file, - recsep => $RECSEP, autochomp => 0, autodefer => 0 - or die "Couldn't tie file: $!"; - splice @a, 1, 0, "x", "y"; - check_contents($badrec, "x", "y"); -} -# (53-56) -if (setup_badly_terminated_file(4)) { - $o = tie @a, 'Tie::File', $file, - recsep => $RECSEP, autochomp => 0, autodefer => 0 - or die "Couldn't tie file: $!"; - my @r = splice @a, 0, 1, "x", "y"; - my $n = @r; - print $n == 1 ? "ok $N\n" : "not ok $N \# expected 1 elt, got $n\n"; - $N++; - print $r[0] eq "$badrec$:" ? "ok $N\n" - : "not ok $N \# expected <$badrec>, got <$r[0]>\n"; - $N++; - check_contents("x", "y"); -} - -# (57-58) 20020402 The modification would have failed if $\ were set wrong. -# I hate $\. -if (setup_badly_terminated_file(2)) { - $o = tie @a, 'Tie::File', $file, - recsep => $RECSEP, autochomp => 0, autodefer => 0 - or die "Couldn't tie file: $!"; - { local $\ = "I hate \$\\."; - my $z = $a[0]; - } - check_contents($badrec); -} - -# (59) 20030527 Tom Christiansen pointed out that FETCH returns the wrong -# data on the final record of an unterminated file if the file is opened -# in read-only mode. Note that the $#a is necessary here. -# There's special-case code to fix the final record when it is read normally. -# But the $#a forces it to be read from the cache, which skips the -# termination. -$badrec = "world${RECSEP}hello"; -if (setup_badly_terminated_file(1)) { - tie(@a, "Tie::File", $file, mode => O_RDONLY, recsep => $RECSEP) - or die "Couldn't tie file: $!"; - my $z = $#a; - $z = $a[1]; - print $z eq "hello" ? "ok $N\n" : - "not ok $N \# got $z, expected hello\n"; - $N++; -} - -sub setup_badly_terminated_file { - my $NTESTS = shift; - open F, "> $file" or die "Couldn't open $file: $!"; - binmode F; - print F $badrec; - close F; - unless (-s $file == length $badrec) { - for (1 .. $NTESTS) { - print "ok $N \# skipped - can't create improperly terminated file\n"; - $N++; - } - return; - } - return 1; -} - - -use POSIX 'SEEK_SET'; -sub check_contents { - my @c = @_; - my $x = join $RECSEP, @c, ''; - local *FH = $o->{fh}; - seek FH, 0, SEEK_SET; - my $a; - { local $/; $a = <FH> } - - $a = "" unless defined $a; - if ($a eq $x) { - print "ok $N\n"; - } else { - my $msg = "# expected <$x>, got <$a>"; - ctrlfix($msg); - print "not ok $N $msg\n"; - } - $N++; - - # now check FETCH: - my $good = 1; - for (0.. $#c) { - unless ($a[$_] eq "$c[$_]$RECSEP") { - $msg = "expected $c[$_]$RECSEP, got $a[$_]"; - ctrlfix($msg); - $good = 0; - } - } - print $good ? "ok $N\n" : "not ok $N # fetch $msg\n"; - $N++; -} - - -sub ctrlfix { - for (@_) { - s/\n/\\n/g; - s/\r/\\r/g; - } -} - - -END { - undef $o; - untie @a; - 1 while unlink $file; -} - diff --git a/lib/Tie/File/t/10_splice_rs.t b/lib/Tie/File/t/10_splice_rs.t deleted file mode 100644 index 50b8b0a7ee..0000000000 --- a/lib/Tie/File/t/10_splice_rs.t +++ /dev/null @@ -1,215 +0,0 @@ -#!/usr/bin/perl -# -# Check SPLICE function's effect on the file -# (07_rv_splice.t checks its return value) -# -# Each call to 'check_contents' actually performs two tests. -# First, it calls the tied object's own 'check_integrity' method, -# which makes sure that the contents of the read cache and offset tables -# accurately reflect the contents of the file. -# Then, it checks the actual contents of the file against the expected -# contents. - -use POSIX 'SEEK_SET'; - -my $file = "tf$$.txt"; -my $data = "rec0blahrec1blahrec2blah"; - -print "1..101\n"; - -my $N = 1; -use Tie::File; -print "ok $N\n"; $N++; # partial credit just for showing up - -init_file($data); - -my $o = tie @a, 'Tie::File', $file, recsep => 'blah'; -print $o ? "ok $N\n" : "not ok $N\n"; -$N++; - -my $n; - -# (3-22) splicing at the beginning -splice(@a, 0, 0, "rec4"); -check_contents("rec4blah$data"); -splice(@a, 0, 1, "rec5"); # same length -check_contents("rec5blah$data"); -splice(@a, 0, 1, "record5"); # longer -check_contents("record5blah$data"); - -splice(@a, 0, 1, "r5"); # shorter -check_contents("r5blah$data"); -splice(@a, 0, 1); # removal -check_contents("$data"); -splice(@a, 0, 0); # no-op -check_contents("$data"); -splice(@a, 0, 0, 'r7', 'rec8'); # insert more than one -check_contents("r7blahrec8blah$data"); -splice(@a, 0, 2, 'rec7', 'record8', 'rec9'); # insert more than delete -check_contents("rec7blahrecord8blahrec9blah$data"); - -splice(@a, 0, 3, 'record9', 'rec10'); # delete more than insert -check_contents("record9blahrec10blah$data"); -splice(@a, 0, 2); # delete more than one -check_contents("$data"); - - -# (23-42) splicing in the middle -splice(@a, 1, 0, "rec4"); -check_contents("rec0blahrec4blahrec1blahrec2blah"); -splice(@a, 1, 1, "rec5"); # same length -check_contents("rec0blahrec5blahrec1blahrec2blah"); -splice(@a, 1, 1, "record5"); # longer -check_contents("rec0blahrecord5blahrec1blahrec2blah"); - -splice(@a, 1, 1, "r5"); # shorter -check_contents("rec0blahr5blahrec1blahrec2blah"); -splice(@a, 1, 1); # removal -check_contents("$data"); -splice(@a, 1, 0); # no-op -check_contents("$data"); -splice(@a, 1, 0, 'r7', 'rec8'); # insert more than one -check_contents("rec0blahr7blahrec8blahrec1blahrec2blah"); -splice(@a, 1, 2, 'rec7', 'record8', 'rec9'); # insert more than delete -check_contents("rec0blahrec7blahrecord8blahrec9blahrec1blahrec2blah"); - -splice(@a, 1, 3, 'record9', 'rec10'); # delete more than insert -check_contents("rec0blahrecord9blahrec10blahrec1blahrec2blah"); -splice(@a, 1, 2); # delete more than one -check_contents("$data"); - -# (43-62) splicing at the end -splice(@a, 3, 0, "rec4"); -check_contents("$ {data}rec4blah"); -splice(@a, 3, 1, "rec5"); # same length -check_contents("$ {data}rec5blah"); -splice(@a, 3, 1, "record5"); # longer -check_contents("$ {data}record5blah"); - -splice(@a, 3, 1, "r5"); # shorter -check_contents("$ {data}r5blah"); -splice(@a, 3, 1); # removal -check_contents("$data"); -splice(@a, 3, 0); # no-op -check_contents("$data"); -splice(@a, 3, 0, 'r7', 'rec8'); # insert more than one -check_contents("$ {data}r7blahrec8blah"); -splice(@a, 3, 2, 'rec7', 'record8', 'rec9'); # insert more than delete -check_contents("$ {data}rec7blahrecord8blahrec9blah"); - -splice(@a, 3, 3, 'record9', 'rec10'); # delete more than insert -check_contents("$ {data}record9blahrec10blah"); -splice(@a, 3, 2); # delete more than one -check_contents("$data"); - -# (63-82) splicing with negative subscript -splice(@a, -1, 0, "rec4"); -check_contents("rec0blahrec1blahrec4blahrec2blah"); -splice(@a, -1, 1, "rec5"); # same length -check_contents("rec0blahrec1blahrec4blahrec5blah"); -splice(@a, -1, 1, "record5"); # longer -check_contents("rec0blahrec1blahrec4blahrecord5blah"); - -splice(@a, -1, 1, "r5"); # shorter -check_contents("rec0blahrec1blahrec4blahr5blah"); -splice(@a, -1, 1); # removal -check_contents("rec0blahrec1blahrec4blah"); -splice(@a, -1, 0); # no-op -check_contents("rec0blahrec1blahrec4blah"); -splice(@a, -1, 0, 'r7', 'rec8'); # insert more than one -check_contents("rec0blahrec1blahr7blahrec8blahrec4blah"); -splice(@a, -1, 2, 'rec7', 'record8', 'rec9'); # insert more than delete -check_contents("rec0blahrec1blahr7blahrec8blahrec7blahrecord8blahrec9blah"); - -splice(@a, -3, 3, 'record9', 'rec10'); # delete more than insert -check_contents("rec0blahrec1blahr7blahrec8blahrecord9blahrec10blah"); -splice(@a, -4, 3); # delete more than one -check_contents("rec0blahrec1blahrec10blah"); - -# (83-84) scrub it all out -splice(@a, 0, 3); -check_contents(""); - -# (85-86) put some back in -splice(@a, 0, 0, "rec0", "rec1"); -check_contents("rec0blahrec1blah"); - -# (87-88) what if we remove too many records? -splice(@a, 0, 17); -check_contents(""); - -# (89-92) In the past, splicing past the end was not correctly detected -# (0.14) -splice(@a, 89, 3); -check_contents(""); -splice(@a, @a, 3); -check_contents(""); - -# (93-96) Also we did not emulate splice's freaky behavior when inserting -# past the end of the array (1.14) -splice(@a, 89, 0, "I", "like", "pie"); -check_contents("Iblahlikeblahpieblah"); -splice(@a, 89, 0, "pie pie pie"); -check_contents("Iblahlikeblahpieblahpie pie pieblah"); - -# (97) Splicing with too large a negative number should be fatal -# This test ignored because it causes 5.6.1 and 5.7.3 to dump core -# It also garbles the stack under 5.005_03 (20020401) -# NOT MY FAULT -if ($] > 5.007003) { - eval { splice(@a, -7, 0) }; - print $@ =~ /^Modification of non-creatable array value attempted, subscript -7/ - ? "ok $N\n" : "not ok $N \# \$\@ was '$@'\n"; -} else { - print "ok $N \# skipped (versions through 5.7.3 dump core here.)\n"; -} -$N++; - -# (98-101) Test default arguments -splice @a, 0, 0, (0..11); -splice @a, 4; -check_contents("0blah1blah2blah3blah"); -splice @a; -check_contents(""); - - -sub init_file { - my $data = shift; - open F, "> $file" or die $!; - binmode F; - print F $data; - close F; -} - -sub check_contents { - my $x = shift; - my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY}); - print $integrity ? "ok $N\n" : "not ok $N\n"; - $N++; - local *FH = $o->{fh}; - seek FH, 0, SEEK_SET; - my $a; - { local $/; $a = <FH> } - $a = "" unless defined $a; - if ($a eq $x) { - print "ok $N\n"; - } else { - ctrlfix(my $msg = "# expected <$x>, got <$a>"); - print "not ok $N\n$msg\n"; - } - $N++; -} - -sub ctrlfix { - for (@_) { - s/\n/\\n/g; - s/\r/\\r/g; - } -} - -END { - undef $o; - untie @a; - 1 while unlink $file; -} - diff --git a/lib/Tie/File/t/11_rv_splice_rs.t b/lib/Tie/File/t/11_rv_splice_rs.t deleted file mode 100644 index ae1053802a..0000000000 --- a/lib/Tie/File/t/11_rv_splice_rs.t +++ /dev/null @@ -1,182 +0,0 @@ -#!/usr/bin/perl -# -# Check SPLICE function's return value -# (04_splice.t checks its effect on the file) -# - -my $file = "tf$$.txt"; -my $data = "rec0blahrec1blahrec2blah"; - -print "1..50\n"; - -my $N = 1; -use Tie::File; -print "ok $N\n"; $N++; # partial credit just for showing up - -init_file($data); - -my $o = tie @a, 'Tie::File', $file, autochomp => 0, recsep => 'blah'; -print $o ? "ok $N\n" : "not ok $N\n"; -$N++; - -my $n; - -# (3-12) splicing at the beginning -@r = splice(@a, 0, 0, "rec4"); -check_result(); -@r = splice(@a, 0, 1, "rec5"); # same length -check_result("rec4"); -@r = splice(@a, 0, 1, "record5"); # longer -check_result("rec5"); - -@r = splice(@a, 0, 1, "r5"); # shorter -check_result("record5"); -@r = splice(@a, 0, 1); # removal -check_result("r5"); -@r = splice(@a, 0, 0); # no-op -check_result(); -@r = splice(@a, 0, 0, 'r7', 'rec8'); # insert more than one -check_result(); -@r = splice(@a, 0, 2, 'rec7', 'record8', 'rec9'); # insert more than delete -check_result('r7', 'rec8'); - -@r = splice(@a, 0, 3, 'record9', 'rec10'); # delete more than insert -check_result('rec7', 'record8', 'rec9'); -@r = splice(@a, 0, 2); # delete more than one -check_result('record9', 'rec10'); - - -# (13-22) splicing in the middle -@r = splice(@a, 1, 0, "rec4"); -check_result(); -@r = splice(@a, 1, 1, "rec5"); # same length -check_result('rec4'); -@r = splice(@a, 1, 1, "record5"); # longer -check_result('rec5'); - -@r = splice(@a, 1, 1, "r5"); # shorter -check_result("record5"); -@r = splice(@a, 1, 1); # removal -check_result("r5"); -@r = splice(@a, 1, 0); # no-op -check_result(); -@r = splice(@a, 1, 0, 'r7', 'rec8'); # insert more than one -check_result(); -@r = splice(@a, 1, 2, 'rec7', 'record8', 'rec9'); # insert more than delete -check_result('r7', 'rec8'); - -@r = splice(@a, 1, 3, 'record9', 'rec10'); # delete more than insert -check_result('rec7', 'record8', 'rec9'); -@r = splice(@a, 1, 2); # delete more than one -check_result('record9','rec10'); - -# (23-32) splicing at the end -@r = splice(@a, 3, 0, "rec4"); -check_result(); -@r = splice(@a, 3, 1, "rec5"); # same length -check_result('rec4'); -@r = splice(@a, 3, 1, "record5"); # longer -check_result('rec5'); - -@r = splice(@a, 3, 1, "r5"); # shorter -check_result('record5'); -@r = splice(@a, 3, 1); # removal -check_result('r5'); -@r = splice(@a, 3, 0); # no-op -check_result(); -@r = splice(@a, 3, 0, 'r7', 'rec8'); # insert more than one -check_result(); -@r = splice(@a, 3, 2, 'rec7', 'record8', 'rec9'); # insert more than delete -check_result('r7', 'rec8'); - -@r = splice(@a, 3, 3, 'record9', 'rec10'); # delete more than insert -check_result('rec7', 'record8', 'rec9'); -@r = splice(@a, 3, 2); # delete more than one -check_result('record9', 'rec10'); - -# (33-42) splicing with negative subscript -@r = splice(@a, -1, 0, "rec4"); -check_result(); -@r = splice(@a, -1, 1, "rec5"); # same length -check_result('rec2'); -@r = splice(@a, -1, 1, "record5"); # longer -check_result("rec5"); - -@r = splice(@a, -1, 1, "r5"); # shorter -check_result("record5"); -@r = splice(@a, -1, 1); # removal -check_result("r5"); -@r = splice(@a, -1, 0); # no-op -check_result(); -@r = splice(@a, -1, 0, 'r7', 'rec8'); # insert more than one -check_result(); -@r = splice(@a, -1, 2, 'rec7', 'record8', 'rec9'); # insert more than delete -check_result('rec4'); - -@r = splice(@a, -3, 3, 'record9', 'rec10'); # delete more than insert -check_result('rec7', 'record8', 'rec9'); -@r = splice(@a, -4, 3); # delete more than one -check_result('r7', 'rec8', 'record9'); - -# (43) scrub it all out -@r = splice(@a, 0, 3); -check_result('rec0', 'rec1', 'rec10'); - -# (44) put some back in -@r = splice(@a, 0, 0, "rec0", "rec1"); -check_result(); - -# (45) what if we remove too many records? -@r = splice(@a, 0, 17); -check_result('rec0', 'rec1'); - -# (46-48) Now check the scalar context return -splice(@a, 0, 0, qw(I like pie)); -my $r; -$r = splice(@a, 0, 0); -print !defined($r) ? "ok $N\n" : "not ok $N \# return should have been undef\n"; -$N++; - -$r = splice(@a, 2, 1); -print $r eq "pieblah" ? "ok $N\n" : "not ok $N \# return should have been 'pie'\n"; -$N++; - -$r = splice(@a, 0, 2); -print $r eq "likeblah" ? "ok $N\n" : "not ok $N \# return should have been 'like'\n"; -$N++; - -# (49-50) Test default arguments -splice @a, 0, 0, (0..11); -@r = splice @a, 4; -check_result(4..11); -@r = splice @a; -check_result(0..3); - -sub init_file { - my $data = shift; - open F, "> $file" or die $!; - binmode F; - print F $data; - close F; -} - -# actual results are in @r. -# expected results are in @_ -sub check_result { - my @x = @_; - s/blah$// for @r; - my $good = 1; - $good = 0 unless @r == @x; - for my $i (0 .. $#r) { - $good = 0 unless $r[$i] eq $x[$i]; - } - print $good ? "ok $N\n" : "not ok $N \# was (@r); should be (@x)\n"; - $N++; -} - -END { - undef $o; - untie @a; - 1 while unlink $file; -} - diff --git a/lib/Tie/File/t/12_longfetch_rs.t b/lib/Tie/File/t/12_longfetch_rs.t deleted file mode 100644 index 6f1905d6af..0000000000 --- a/lib/Tie/File/t/12_longfetch_rs.t +++ /dev/null @@ -1,41 +0,0 @@ -#!/usr/bin/perl -# -# Make sure we can fetch a record in the middle of the file -# before we've ever looked at any records before it -# -# (tests _fill_offsets_to() ) -# - -my $file = "tf$$.txt"; -my $data = "rec0blahrec1blahrec2blah"; - -print "1..5\n"; - -my $N = 1; -use Tie::File; -print "ok $N\n"; $N++; - -open F, "> $file" or die $!; -binmode F; -print F $data; -close F; - - -my $o = tie @a, 'Tie::File', $file, autochomp => 0, recsep => 'blah'; -print $o ? "ok $N\n" : "not ok $N\n"; -$N++; - -my $n; - -# 3-5 -for (2, 1, 0) { - print $a[$_] eq "rec${_}blah" ? "ok $N\n" : "not ok $N # rec=$a[$_] ?\n"; - $N++; -} - -END { - undef $o; - untie @a; - 1 while unlink $file; -} - diff --git a/lib/Tie/File/t/13_size_rs.t b/lib/Tie/File/t/13_size_rs.t deleted file mode 100644 index a2a8d53bdd..0000000000 --- a/lib/Tie/File/t/13_size_rs.t +++ /dev/null @@ -1,95 +0,0 @@ -#!/usr/bin/perl -# -# Check FETCHSIZE and SETSIZE functions -# PUSH POP SHIFT UNSHIFT -# - -use POSIX 'SEEK_SET'; - -my $file = "tf$$.txt"; -my $data = "rec0blahrec1blahrec2blah"; -my ($o, $n); - -print "1..10\n"; - -my $N = 1; -use Tie::File; -print "ok $N\n"; $N++; - -# 2-3 FETCHSIZE 0-length file -open F, "> $file" or die $!; -close F; -$o = tie @a, 'Tie::File', $file, recsep => 'blah'; -print $o ? "ok $N\n" : "not ok $N\n"; -$N++; -$n = @a; -print $n == 0 ? "ok $N\n" : "not ok $N # $n, s/b 0\n"; -$N++; - -# Reset everything -undef $o; -untie @a; - -# 4-5 FETCHSIZE positive-length file -open F, "> $file" or die $!; -print F $data; -close F; -$o = tie @a, 'Tie::File', $file, recsep => 'blah'; -print $o ? "ok $N\n" : "not ok $N\n"; -$N++; -$n = @a; -print $n == 3 ? "ok $N\n" : "not ok $N # $n, s/b 0\n"; -$N++; - -# STORESIZE -# 6 Make it longer: -$#a = 4; -check_contents("${data}blahblah"); - -# 7 Make it longer again: -$#a = 6; -check_contents("${data}blahblahblahblah"); - -# 8 Make it shorter: -$#a = 4; -check_contents("${data}blahblah"); - -# 9 Make it shorter again: -$#a = 2; -check_contents($data); - -# 10 Get rid of it completely: -$#a = -1; -check_contents(''); - - -sub check_contents { - my $x = shift; - local *FH = $o->{fh}; - seek FH, 0, SEEK_SET; - my $a; - { local $/; $a = <FH> } - $a = "" unless defined $a; - if ($a eq $x) { - print "ok $N\n"; - } else { - ctrlfix(my $msg = "# expected <$x>, got <$a>"); - print "not ok $N\n$msg\n"; - } - $N++; -} - - -sub ctrlfix { - for (@_) { - s/\n/\\n/g; - s/\r/\\r/g; - } -} - -END { - undef $o; - untie @a; - 1 while unlink $file; -} - diff --git a/lib/Tie/File/t/14_lock.t b/lib/Tie/File/t/14_lock.t deleted file mode 100644 index cab48125b0..0000000000 --- a/lib/Tie/File/t/14_lock.t +++ /dev/null @@ -1,50 +0,0 @@ -#!/usr/bin/perl -# -# Check flock() feature -# -# This isn't a real test; it just checks to make sure we can call the method. -# It doesn't even check to make sure that the default behavior -# (LOCK_EX) is occurring. This is because I don't know how to write a good -# portable test for flocking. I checked the Perl core distribution, -# and found that Perl doesn't test flock either! - -BEGIN { - eval { flock STDOUT, 0 }; - if ($@ && $@ =~ /unimplemented/) { - print "1..0\n"; - exit; - } -} - -use Fcntl ':flock'; # This works at least back to 5.004_04 - -my $file = "tf$$.txt"; -my ($o, $n); -my @a; - -print "1..4\n"; - -my $N = 1; -use Tie::File; -print "ok $N\n"; $N++; - -# 2-4 Who the heck knows? -open F, "> $file" or die $!; -close F; -$o = tie @a, 'Tie::File', $file, recsep => 'blah'; -print $o ? "ok $N\n" : "not ok $N\n"; -$N++; - -print $o->flock() ? "ok $N\n" : "not ok $N\n"; -$N++; - -print $o->flock(LOCK_UN) ? "ok $N\n" : "not ok $N\n"; -$N++; - - -END { - undef $o; - untie @a; - 1 while unlink $file; -} - diff --git a/lib/Tie/File/t/15_pushpop.t b/lib/Tie/File/t/15_pushpop.t deleted file mode 100644 index 4b6d1bc959..0000000000 --- a/lib/Tie/File/t/15_pushpop.t +++ /dev/null @@ -1,135 +0,0 @@ -#!/usr/bin/perl -# -# Check PUSH, POP, SHIFT, and UNSHIFT -# -# Each call to 'check_contents' actually performs two tests. -# First, it calls the tied object's own 'check_integrity' method, -# which makes sure that the contents of the read cache and offset tables -# accurately reflect the contents of the file. -# Then, it checks the actual contents of the file against the expected -# contents. - -use POSIX 'SEEK_SET'; - -my $file = "tf$$.txt"; -1 while unlink $file; -$: = Tie::File::_default_recsep(); -my $data = "rec0$:rec1$:rec2$:"; - -print "1..38\n"; - -my $N = 1; -use Tie::File; -print "ok $N\n"; $N++; # partial credit just for showing up - -my $o = tie @a, 'Tie::File', $file, autochomp => 0; -print $o ? "ok $N\n" : "not ok $N\n"; -$N++; -my ($n, @r); - - -# (3-11) PUSH tests -$n = push @a, "rec0", "rec1", "rec2"; -check_contents($data); -print $n == 3 ? "ok $N\n" : "not ok $N # size is $n, should be 3\n"; -$N++; - -$n = push @a, "rec3", "rec4$:"; -check_contents("$ {data}rec3$:rec4$:"); -print $n == 5 ? "ok $N\n" : "not ok $N # size is $n, should be 5\n"; -$N++; - -# Trivial push -$n = push @a, (); -check_contents("$ {data}rec3$:rec4$:"); -print $n == 5 ? "ok $N\n" : "not ok $N # size is $n, should be 5\n"; -$N++; - -# (12-20) POP tests -$n = pop @a; -check_contents("$ {data}rec3$:"); -print $n eq "rec4$:" ? "ok $N\n" : "not ok $N # last rec is $n, should be rec4\n"; -$N++; - -# Presumably we have already tested this to death -splice(@a, 1, 3); -$n = pop @a; -check_contents(""); -print $n eq "rec0$:" ? "ok $N\n" : "not ok $N # last rec is $n, should be rec0\n"; -$N++; - -$n = pop @a; -check_contents(""); -print ! defined $n ? "ok $N\n" : "not ok $N # last rec should be undef, is $n\n"; -$N++; - - -# (21-29) UNSHIFT tests -$n = unshift @a, "rec0", "rec1", "rec2"; -check_contents($data); -print $n == 3 ? "ok $N\n" : "not ok $N # size is $n, should be 3\n"; -$N++; - -$n = unshift @a, "rec3", "rec4$:"; -check_contents("rec3$:rec4$:$data"); -print $n == 5 ? "ok $N\n" : "not ok $N # size is $n, should be 5\n"; -$N++; - -# Trivial unshift -$n = unshift @a, (); -check_contents("rec3$:rec4$:$data"); -print $n == 5 ? "ok $N\n" : "not ok $N # size is $n, should be 5\n"; -$N++; - -# (30-38) SHIFT tests -$n = shift @a; -check_contents("rec4$:$data"); -print $n eq "rec3$:" ? "ok $N\n" : "not ok $N # last rec is $n, should be rec3\n"; -$N++; - -# Presumably we have already tested this to death -splice(@a, 1, 3); -$n = shift @a; -check_contents(""); -print $n eq "rec4$:" ? "ok $N\n" : "not ok $N # last rec is $n, should be rec4\n"; -$N++; - -$n = shift @a; -check_contents(""); -print ! defined $n ? "ok $N\n" : "not ok $N # last rec should be undef, is $n\n"; -$N++; - - -sub check_contents { - my $x = shift; - my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY}); - print $integrity ? "ok $N\n" : "not ok $N\n"; - $N++; - - local *FH = $o->{fh}; - seek FH, 0, SEEK_SET; - my $a; - { local $/; $a = <FH> } - $a = "" unless defined $a; - if ($a eq $x) { - print "ok $N\n"; - } else { - ctrlfix(my $msg = "# expected <$x>, got <$a>"); - print "not ok $N\n$msg\n"; - } - $N++; -} - -sub ctrlfix { - for (@_) { - s/\n/\\n/g; - s/\r/\\r/g; - } -} - -END { - undef $o; - untie @a; - 1 while unlink $file; -} - diff --git a/lib/Tie/File/t/16_handle.t b/lib/Tie/File/t/16_handle.t deleted file mode 100644 index f799496be1..0000000000 --- a/lib/Tie/File/t/16_handle.t +++ /dev/null @@ -1,160 +0,0 @@ -#!/usr/bin/perl -# -# Basic operation, initializing the object from an already-open handle -# instead of from a filename - -my $file = "tf$$.txt"; -$: = Tie::File::_default_recsep(); - -if ($^O =~ /vms/i) { - print "1..0\n"; - exit; -} - -print "1..39\n"; - -my $N = 1; -use Tie::File; -print "ok $N\n"; $N++; - -use Fcntl 'O_CREAT', 'O_RDWR'; -sysopen F, $file, O_CREAT | O_RDWR - or die "Couldn't create temp file $file: $!; aborting"; -binmode F; - -my $o = tie @a, 'Tie::File', \*F, autochomp => 0, autodefer => 0; -print $o ? "ok $N\n" : "not ok $N\n"; -$N++; - -# 3-4 create -$a[0] = 'rec0'; -check_contents("rec0"); - -# 5-8 append -$a[1] = 'rec1'; -check_contents("rec0", "rec1"); -$a[2] = 'rec2'; -check_contents("rec0", "rec1", "rec2"); - -# 9-14 same-length alterations -$a[0] = 'new0'; -check_contents("new0", "rec1", "rec2"); -$a[1] = 'new1'; -check_contents("new0", "new1", "rec2"); -$a[2] = 'new2'; -check_contents("new0", "new1", "new2"); - -# 15-24 lengthening alterations -$a[0] = 'long0'; -check_contents("long0", "new1", "new2"); -$a[1] = 'long1'; -check_contents("long0", "long1", "new2"); -$a[2] = 'long2'; -check_contents("long0", "long1", "long2"); -$a[1] = 'longer1'; -check_contents("long0", "longer1", "long2"); -$a[0] = 'longer0'; -check_contents("longer0", "longer1", "long2"); - -# 25-38 shortening alterations, including truncation -$a[0] = 'short0'; -check_contents("short0", "longer1", "long2"); -$a[1] = 'short1'; -check_contents("short0", "short1", "long2"); -$a[2] = 'short2'; -check_contents("short0", "short1", "short2"); -$a[1] = 'sh1'; -check_contents("short0", "sh1", "short2"); -$a[0] = 'sh0'; -check_contents("sh0", "sh1", "short2"); - -# file with holes -$a[4] = 'rec4'; -check_contents("sh0", "sh1", "short2", "", "rec4"); -$a[3] = 'rec3'; -check_contents("sh0", "sh1", "short2", "rec3", "rec4"); - -close F; -undef $o; -untie @a; - -# (39) Does it correctly detect a non-seekable handle? -{ if ($^O =~ /^(MSWin32|dos|beos)$/) { - print "ok $N # skipped ($^O has broken pipe semantics)\n"; - last; - } - if ($] < 5.006) { - print "ok $N # skipped - 5.005_03 panics after this test\n"; - last; - } - my $pipe_succeeded = eval {pipe *R, *W}; - if ($@) { - chomp $@; - print "ok $N # skipped (no pipes: $@)\n"; - last; - } elsif (! $pipe_succeeded) { - print "ok $N # skipped (pipe call failed: $!)\n"; - last; - } - close R; - $o = eval {tie @a, 'Tie::File', \*W}; - if ($@) { - if ($@ =~ /filehandle does not appear to be seekable/) { - print "ok $N\n"; - } else { - chomp $@; - print "not ok $N \# \$\@ is $@\n"; - } - } else { - print "not ok $N \# passing pipe to TIEARRAY didn't abort program\n"; - } - $N++; -} - -use POSIX 'SEEK_SET'; -sub check_contents { - my @c = @_; - my $x = join $:, @c, ''; - local *FH = $o->{fh}; - seek FH, 0, SEEK_SET; -# my $open = open FH, "< $file"; - my $a; - { local $/; $a = <FH> } - $a = "" unless defined $a; - if ($a eq $x) { - print "ok $N\n"; - } else { - ctrlfix(my $msg = "# expected <$x>, got <$a>"); - print "not ok $N\n$msg\n"; - } - $N++; - - # now check FETCH: - my $good = 1; - my $msg; - for (0.. $#c) { - unless ($a[$_] eq "$c[$_]$:") { - $msg = "expected $c[$_]$:, got $a[$_]"; - ctrlfix($msg); - $good = 0; - } - } - print $good ? "ok $N\n" : "not ok $N # $msg\n"; - $N++; -} - - -sub ctrlfix { - for (@_) { - s/\n/\\n/g; - s/\r/\\r/g; - } -} - -END { - undef $o; - untie @a; - 1 while unlink $file; -} - - diff --git a/lib/Tie/File/t/17_misc_meth.t b/lib/Tie/File/t/17_misc_meth.t deleted file mode 100644 index 020774bb91..0000000000 --- a/lib/Tie/File/t/17_misc_meth.t +++ /dev/null @@ -1,158 +0,0 @@ -#!/usr/bin/perl -# -# Check miscellaneous tied-array interface methods -# EXTEND, CLEAR, DELETE, EXISTS -# - -my $file = "tf$$.txt"; -$: = Tie::File::_default_recsep(); -1 while unlink $file; - -print "1..35\n"; - -my $N = 1; -use Tie::File; -print "ok $N\n"; $N++; - -my $o = tie @a, 'Tie::File', $file, autodefer => 0; -print $o ? "ok $N\n" : "not ok $N\n"; -$N++; - -# (3-8) EXTEND -$o->EXTEND(3); -check_contents("$:$:$:"); -$o->EXTEND(4); -check_contents("$:$:$:$:"); -$o->EXTEND(3); -check_contents("$:$:$:$:"); - -# (9-10) CLEAR -@a = (); -check_contents(""); - -# (11-20) EXISTS -if ($] >= 5.006) { - eval << 'TESTS'; -print !exists $a[0] ? "ok $N\n" : "not ok $N\n"; -$N++; -$a[0] = "I like pie."; -print exists $a[0] ? "ok $N\n" : "not ok $N\n"; -$N++; -print !exists $a[1] ? "ok $N\n" : "not ok $N\n"; -$N++; -$a[2] = "GIVE ME PIE"; -print exists $a[0] ? "ok $N\n" : "not ok $N\n"; -$N++; -# exists $a[1] is not defined by this module under these circumstances -print exists $a[1] ? "ok $N\n" : "ok $N\n"; -$N++; -print exists $a[2] ? "ok $N\n" : "not ok $N\n"; -$N++; -print exists $a[-1] ? "ok $N\n" : "not ok $N\n"; -$N++; -print exists $a[-2] ? "ok $N\n" : "not ok $N\n"; -$N++; -print exists $a[-3] ? "ok $N\n" : "not ok $N\n"; -$N++; -print !exists $a[-4] ? "ok $N\n" : "not ok $N\n"; -$N++; -TESTS - } else { # perl 5.005 doesn't have exists $array[1] - for (11..20) { - print "ok $_ \# skipped (no exists for arrays)\n"; - $N++; - } - } - -my $del; - -# (21-35) DELETE -if ($] >= 5.006) { - eval << 'TESTS'; -$del = delete $a[0]; -check_contents("$:$:GIVE ME PIE$:"); -# 20020317 Through 0.20, the 'delete' function returned the wrong values. -expect($del, "I like pie."); -$del = delete $a[2]; -check_contents("$:$:"); -expect($del, "GIVE ME PIE"); -$del = delete $a[0]; -check_contents("$:$:"); -expect($del, ""); -$del = delete $a[1]; -check_contents("$:"); -expect($del, ""); - -# 20020317 Through 0.20, we had a bug where deleting an element past the -# end of the array would actually extend the array to that length. -$del = delete $a[4]; -check_contents("$:"); -expect($del, undef); - - - -TESTS - } else { # perl 5.005 doesn't have delete $array[1] - for (21..35) { - print "ok $_ \# skipped (no delete for arrays)\n"; - $N++; - } - } - -use POSIX 'SEEK_SET'; -sub check_contents { - my $x = shift; - local *FH = $o->{fh}; - seek FH, 0, SEEK_SET; - my $a; - { local $/; $a = <FH> } - $a = "" unless defined $a; - if ($a eq $x) { - print "ok $N\n"; - } else { - ctrlfix(my $msg = "# expected <$x>, got <$a>"); - print "not ok $N # $msg\n"; - } - $N++; - print $o->_check_integrity($file, $ENV{INTEGRITY}) ? "ok $N\n" : "not ok $N\n"; - $N++; -} - -sub expect { - if (@_ == 1) { - print $_[0] ? "ok $N\n" : "not ok $N\n"; - } elsif (@_ == 2) { - my ($a, $x) = @_; - if (! defined($a) && ! defined($x)) { print "ok $N\n" } - elsif ( defined($a) && ! defined($x)) { - ctrlfix(my $msg = "expected UNDEF, got <$a>"); - print "not ok $N \# $msg\n"; - } - elsif (! defined($a) && defined($x)) { - ctrlfix(my $msg = "expected <$x>, got UNDEF"); - print "not ok $N \# $msg\n"; - } elsif ($a eq $x) { print "ok $N\n" } - else { - ctrlfix(my $msg = "expected <$x>, got <$a>"); - print "not ok $N \# $msg\n"; - } - } else { - die "expect() got ", scalar(@_), " args, should have been 1 or 2"; - } - $N++; -} - -sub ctrlfix { - for (@_) { - s/\n/\\n/g; - s/\r/\\r/g; - } -} - -END { - undef $o; - untie @a; - 1 while unlink $file; -} - - diff --git a/lib/Tie/File/t/18_rs_fixrec.t b/lib/Tie/File/t/18_rs_fixrec.t deleted file mode 100644 index 3c2a807e64..0000000000 --- a/lib/Tie/File/t/18_rs_fixrec.t +++ /dev/null @@ -1,53 +0,0 @@ -#!/usr/bin/perl - -use POSIX 'SEEK_SET'; -my $file = "tf$$.txt"; -$/ = "blah"; - -print "1..5\n"; - -my $N = 1; -use Tie::File; -print "ok $N\n"; $N++; - -my $o = tie @a, 'Tie::File', $file, autodefer => 0; -print $o ? "ok $N\n" : "not ok $N\n"; -$N++; - -$a[0] = 'rec0'; -check_contents("rec0blah"); -$a[1] = "rec1blah"; -check_contents("rec0blahrec1blah"); -$a[2] = "rec2blahblah"; # should we detect this? -check_contents("rec0blahrec1blahrec2blahblah"); - -sub check_contents { - my $x = shift; - local *FH = $o->{fh}; - seek FH, 0, SEEK_SET; - my $a; - { local $/; $a = <FH> } - $a = "" unless defined $a; - if ($a eq $x) { - print "ok $N\n"; - } else { - my $msg = "not ok $N # expected <$x>, got <$a>"; - ctrlfix($msg); - print "$msg\n"; - } - $N++; -} - -sub ctrlfix { - for (@_) { - s/\n/\\n/g; - s/\r/\\r/g; - } -} - -END { - undef $o; - untie @a; - 1 while unlink $file; -} - diff --git a/lib/Tie/File/t/19_cache.t b/lib/Tie/File/t/19_cache.t deleted file mode 100644 index 81c693263e..0000000000 --- a/lib/Tie/File/t/19_cache.t +++ /dev/null @@ -1,205 +0,0 @@ -#!/usr/bin/perl -# -# Tests for various caching errors -# - -$|=1; -my $file = "tf$$.txt"; -$: = Tie::File::_default_recsep(); -my $data = join $:, "rec0" .. "rec9", ""; -my $V = $ENV{INTEGRITY}; # Verbose integrity checking? - -print "1..55\n"; - -my $N = 1; -use Tie::File; -print "ok $N\n"; $N++; - -open F, "> $file" or die $!; -binmode F; -print F $data; -close F; - -my $o = tie @a, 'Tie::File', $file; -print $o ? "ok $N\n" : "not ok $N\n"; -$N++; - -# (3) Through 0.18, this 'splice' call would corrupt the cache. -my @z = @a; # force cache to contain all ten records -splice @a, 0, 0, "x"; -print $o->_check_integrity($file, $V) ? "ok $N\n" : "not ok $N\n"; -$N++; - -# Here we redo *all* the splice tests, with populate() -# calls before each one, to make sure that splice() does not botch the cache. - -# (4-14) splicing at the beginning -check(); -splice(@a, 0, 0, "rec4"); -check(); -splice(@a, 0, 1, "rec5"); # same length -check(); -splice(@a, 0, 1, "record5"); # longer -check(); -splice(@a, 0, 1, "r5"); # shorter -check(); -splice(@a, 0, 1); # removal -check(); -splice(@a, 0, 0); # no-op -check(); - -splice(@a, 0, 0, 'r7', 'rec8'); # insert more than one -check(); -splice(@a, 0, 2, 'rec7', 'record8', 'rec9'); # insert more than delete -check(); -splice(@a, 0, 3, 'record9', 'rec10'); # delete more than insert -check(); -splice(@a, 0, 2); # delete more than one -check(); - - -# (15-24) splicing in the middle -splice(@a, 1, 0, "rec4"); -check(); -splice(@a, 1, 1, "rec5"); # same length -check(); -splice(@a, 1, 1, "record5"); # longer -check(); -splice(@a, 1, 1, "r5"); # shorter -check(); -splice(@a, 1, 1); # removal -check(); -splice(@a, 1, 0); # no-op -check(); - -splice(@a, 1, 0, 'r7', 'rec8'); # insert more than one -check(); -splice(@a, 1, 2, 'rec7', 'record8', 'rec9'); # insert more than delete -check(); -splice(@a, 1, 3, 'record9', 'rec10'); # delete more than insert -check(); -splice(@a, 1, 2); # delete more than one -check(); - -# (25-34) splicing at the end -splice(@a, 3, 0, "rec4"); -check(); -splice(@a, 3, 1, "rec5"); # same length -check(); -splice(@a, 3, 1, "record5"); # longer -check(); -splice(@a, 3, 1, "r5"); # shorter -check(); -splice(@a, 3, 1); # removal -check(); -splice(@a, 3, 0); # no-op -check(); - -splice(@a, 3, 0, 'r7', 'rec8'); # insert more than one -check(); -splice(@a, 3, 2, 'rec7', 'record8', 'rec9'); # insert more than delete -check(); -splice(@a, 3, 3, 'record9', 'rec10'); # delete more than insert -check(); -splice(@a, 3, 2); # delete more than one -check(); - -# (35-44) splicing with negative subscript -splice(@a, -1, 0, "rec4"); -check(); -splice(@a, -1, 1, "rec5"); # same length -check(); -splice(@a, -1, 1, "record5"); # longer -check(); -splice(@a, -1, 1, "r5"); # shorter -check(); -splice(@a, -1, 1); # removal -check(); -splice(@a, -1, 0); # no-op -check(); - -splice(@a, -1, 0, 'r7', 'rec8'); # insert more than one -check(); -splice(@a, -1, 2, 'rec7', 'record8', 'rec9'); # insert more than delete -check(); -splice(@a, -3, 3, 'record9', 'rec10'); # delete more than insert -check(); -splice(@a, -4, 3); # delete more than one -check(); - -# (45) scrub it all out -splice(@a, 0, 3); -check(); - -# (46) put some back in -splice(@a, 0, 0, "rec0", "rec1"); -check(); - -# (47) what if we remove too many records? -splice(@a, 0, 17); -check(); - -# (48-49) In the past, splicing past the end was not correctly detected -# (1.14) -splice(@a, 89, 3); -check(); -splice(@a, @a, 3); -check(); - -# (50-51) Also we did not emulate splice's freaky behavior when inserting -# past the end of the array (1.14) -splice(@a, 89, 0, "I", "like", "pie"); -check(); -splice(@a, 89, 0, "pie pie pie"); -check(); - -# (52-54) Test default arguments -splice @a, 0, 0, (0..11); -check(); -splice @a, 4; -check(); -splice @a; -check(); - -# (55) This was broken on 20030507 when you moved the cache management -# stuff out of _oadjust back into _splice without also putting it back -# into _store. -@a = (0..11); -check(); - -sub init_file { - my $data = shift; - open F, "> $file" or die $!; - binmode F; - print F $data; - close F; -} - -sub check { - my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY}); - print $integrity ? "ok $N\n" : "not ok $N\n"; - $N++; - repopulate(); -} - - -sub ctrlfix { - for (@_) { - s/\n/\\n/g; - s/\r/\\r/g; - } -} - -sub repopulate { - $o->{cache}->empty; - my @z = @a; # refill the cache with correct data -} - -END { - undef $o; - untie @a; - 1 while unlink $file; -} - - - diff --git a/lib/Tie/File/t/20_cache_full.t b/lib/Tie/File/t/20_cache_full.t deleted file mode 100644 index 8b3bf0b2e0..0000000000 --- a/lib/Tie/File/t/20_cache_full.t +++ /dev/null @@ -1,228 +0,0 @@ -#!/usr/bin/perl -# -# Tests for various caching errors -# - -my $file = "tf$$.txt"; -$: = Tie::File::_default_recsep(); -my $data = join $:, "record0" .. "record9", ""; -my $V = $ENV{INTEGRITY}; # Verbose integrity checking? - -print "1..111\n"; - -my $N = 1; -use Tie::File; -print "ok $N\n"; $N++; - -open F, "> $file" or die $!; -binmode F; -print F $data; -close F; - -# Limit cache size to 30 bytes -my $MAX = 30; -# -- that's enough space for 3 records, but not 4, on both \n and \r\n systems -my $o = tie @a, 'Tie::File', $file, memory => $MAX, autodefer => 0; -print $o ? "ok $N\n" : "not ok $N\n"; -$N++; - -# (3-5) Let's see if data was properly expired from the cache -my @z = @a; # force cache to contain all ten records -# It should now contain only the *last* three records, 7, 8, and 9 -{ - my $x = "7 8 9"; - my $a = join " ", sort $o->{cache}->ckeys; - if ($a eq $x) { print "ok $N\n" } - else { print "not ok $N # cache keys were <$a>; expected <$x>\n" } - $N++; -} -check(); - -# Here we redo *all* the splice tests, with populate() -# calls before each one, to make sure that splice() does not botch the cache. - -# (6-25) splicing at the beginning -splice(@a, 0, 0, "rec4"); -check(); -splice(@a, 0, 1, "rec5"); # same length -check(); -splice(@a, 0, 1, "record5"); # longer -check(); -splice(@a, 0, 1, "r5"); # shorter -check(); -splice(@a, 0, 1); # removal -check(); -splice(@a, 0, 0); # no-op -check(); - -splice(@a, 0, 0, 'r7', 'rec8'); # insert more than one -check(); -splice(@a, 0, 2, 'rec7', 'record8', 'rec9'); # insert more than delete -check(); -splice(@a, 0, 3, 'record9', 'rec10'); # delete more than insert -check(); -splice(@a, 0, 2); # delete more than one -check(); - - -# (26-45) splicing in the middle -splice(@a, 1, 0, "rec4"); -check(); -splice(@a, 1, 1, "rec5"); # same length -check(); -splice(@a, 1, 1, "record5"); # longer -check(); -splice(@a, 1, 1, "r5"); # shorter -check(); -splice(@a, 1, 1); # removal -check(); -splice(@a, 1, 0); # no-op -check(); - -splice(@a, 1, 0, 'r7', 'rec8'); # insert more than one -check(); -splice(@a, 1, 2, 'rec7', 'record8', 'rec9'); # insert more than delete -check(); -splice(@a, 1, 3, 'record9', 'rec10'); # delete more than insert -check(); -splice(@a, 1, 2); # delete more than one -check(); - -# (46-65) splicing at the end -splice(@a, 3, 0, "rec4"); -check(); -splice(@a, 3, 1, "rec5"); # same length -check(); -splice(@a, 3, 1, "record5"); # longer -check(); -splice(@a, 3, 1, "r5"); # shorter -check(); -splice(@a, 3, 1); # removal -check(); -splice(@a, 3, 0); # no-op -check(); - -splice(@a, 3, 0, 'r7', 'rec8'); # insert more than one -check(); -splice(@a, 3, 2, 'rec7', 'record8', 'rec9'); # insert more than delete -check(); -splice(@a, 3, 3, 'record9', 'rec10'); # delete more than insert -check(); -splice(@a, 3, 2); # delete more than one -check(); - -# (66-85) splicing with negative subscript -splice(@a, -1, 0, "rec4"); -check(); -splice(@a, -1, 1, "rec5"); # same length -check(); -splice(@a, -1, 1, "record5"); # longer -check(); -splice(@a, -1, 1, "r5"); # shorter -check(); -splice(@a, -1, 1); # removal -check(); -splice(@a, -1, 0); # no-op -check(); - -splice(@a, -1, 0, 'r7', 'rec8'); # insert more than one -check(); -splice(@a, -1, 2, 'rec7', 'record8', 'rec9'); # insert more than delete -check(); -splice(@a, -3, 3, 'record9', 'rec10'); # delete more than insert -check(); -splice(@a, -4, 3); # delete more than one -check(); - -# (86-87) scrub it all out -splice(@a, 0, 3); -check(); - -# (88-89) put some back in -splice(@a, 0, 0, "rec0", "rec1"); -check(); - -# (90-91) what if we remove too many records? -splice(@a, 0, 17); -check(); - -# (92-95) In the past, splicing past the end was not correctly detected -# (1.14) -splice(@a, 89, 3); -check(); -splice(@a, @a, 3); -check(); - -# (96-99) Also we did not emulate splice's freaky behavior when inserting -# past the end of the array (1.14) -splice(@a, 89, 0, "I", "like", "pie"); -check(); -splice(@a, 89, 0, "pie pie pie"); -check(); - -# (100-105) Test default arguments -splice @a, 0, 0, (0..11); -check(); -splice @a, 4; -check(); -splice @a; -check(); - -# (106-111) One last set of tests. I don't know what state the cache -# is in now. But if I read any three records, those three records are -# what should be in the cache, and nothing else. -@a = "record0" .. "record9"; -check(); # In 0.18 #107 fails here--STORE was not flushing the cache when - # replacing an old cached record with a longer one -for (5, 6, 1) { my $z = $a[$_] } -{ - my $x = "5 6 1"; - my $a = join " ", $o->{cache}->_produce_lru; - if ($a eq $x) { print "ok $N\n" } - else { print "not ok $N # LRU was <$a>; expected <$x>\n" } - $N++; - $x = "1 5 6"; - $a = join " ", sort $o->{cache}->ckeys; - if ($a eq $x) { print "ok $N\n" } - else { print "not ok $N # cache keys were <$a>; expected <$x>\n" } - $N++; -} -check(); - - -sub init_file { - my $data = shift; - open F, "> $file" or die $!; - binmode F; - print F $data; - close F; -} - -sub check { - my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY}); - print $integrity ? "ok $N\n" : "not ok $N\n"; - $N++; - - my $b = $o->{cache}->bytes; - print $b <= $MAX - ? "ok $N\n" - : "not ok $N # $b bytes cached, should be <= $MAX\n"; - $N++; -} - - -sub ctrlfix { - for (@_) { - s/\n/\\n/g; - s/\r/\\r/g; - } -} - -END { - undef $o; - untie @a; - 1 while unlink $file; -} - - - diff --git a/lib/Tie/File/t/21_win32.t b/lib/Tie/File/t/21_win32.t deleted file mode 100644 index d06854441b..0000000000 --- a/lib/Tie/File/t/21_win32.t +++ /dev/null @@ -1,61 +0,0 @@ -#!/usr/bin/perl -# -# Formerly, on a Win32 system, Tie::File would create files with -# \n-terminated records instead of \r\n-terminated. The tests never -# picked this up because they were using $/ everywhere, and $/ is \n -# on windows systems. -# -# These tests (Win32 only) make sure that the file had \r\n as it should. - -my $file = "tf$$.txt"; - -unless ($^O =~ /^(MSWin32|dos)$/) { - print "1..0\n"; - exit; -} - - -print "1..3\n"; - -my $N = 1; -use Tie::File; -print "ok $N\n"; $N++; - -my $o = tie @a, 'Tie::File', $file, autodefer => 0; -print $o ? "ok $N\n" : "not ok $N\n"; -$N++; - -my $n; - -# (3) Make sure that on Win32 systems, the file is written with \r\n by default -@a = qw(fish dog carrot); -undef $o; -untie @a; -open F, "< $file" or die "Couldn't open file $file: $!"; -binmode F; -my $a = do {local $/ ; <F> }; -my $x = "fish\r\ndog\r\ncarrot\r\n" ; -if ($a eq $x) { - print "ok $N\n"; -} else { - ctrlfix(my $msg = "expected <$x>, got <$a>"); - print "not ok $N # $msg\n"; -} - -close F; - -sub ctrlfix { - for (@_) { - s/\n/\\n/g; - s/\r/\\r/g; - } -} - - - -END { - undef $o; - untie @a; - 1 while unlink $file; -} - diff --git a/lib/Tie/File/t/22_autochomp.t b/lib/Tie/File/t/22_autochomp.t deleted file mode 100644 index dee07a8ec8..0000000000 --- a/lib/Tie/File/t/22_autochomp.t +++ /dev/null @@ -1,175 +0,0 @@ -#!/usr/bin/perl - -my $file = "tf$$.txt"; -$: = Tie::File::_default_recsep(); - -print "1..71\n"; - -my $N = 1; -use Tie::File; -print "ok $N\n"; $N++; - -my $o = tie @a, 'Tie::File', $file, autochomp => 1, autodefer => 0; -print $o ? "ok $N\n" : "not ok $N\n"; -$N++; - -# 3-5 create -$a[0] = 'rec0'; -check_contents("rec0"); - -# 6-11 append -$a[1] = 'rec1'; -check_contents("rec0", "rec1"); -$a[2] = 'rec2'; -check_contents("rec0", "rec1", "rec2"); - -# 12-20 same-length alterations -$a[0] = 'new0'; -check_contents("new0", "rec1", "rec2"); -$a[1] = 'new1'; -check_contents("new0", "new1", "rec2"); -$a[2] = 'new2'; -check_contents("new0", "new1", "new2"); - -# 21-35 lengthening alterations -$a[0] = 'long0'; -check_contents("long0", "new1", "new2"); -$a[1] = 'long1'; -check_contents("long0", "long1", "new2"); -$a[2] = 'long2'; -check_contents("long0", "long1", "long2"); -$a[1] = 'longer1'; -check_contents("long0", "longer1", "long2"); -$a[0] = 'longer0'; -check_contents("longer0", "longer1", "long2"); - -# 36-50 shortening alterations, including truncation -$a[0] = 'short0'; -check_contents("short0", "longer1", "long2"); -$a[1] = 'short1'; -check_contents("short0", "short1", "long2"); -$a[2] = 'short2'; -check_contents("short0", "short1", "short2"); -$a[1] = 'sh1'; -check_contents("short0", "sh1", "short2"); -$a[0] = 'sh0'; -check_contents("sh0", "sh1", "short2"); - -# (51-56) file with holes -$a[4] = 'rec4'; -check_contents("sh0", "sh1", "short2", "", "rec4"); -$a[3] = 'rec3'; -check_contents("sh0", "sh1", "short2", "rec3", "rec4"); - -# (57-59) zero out file -@a = (); -check_contents(); - -# (60-62) insert into the middle of an empty file -$a[3] = "rec3"; -check_contents("", "", "", "rec3"); - -# (63-68) Test the ->autochomp() method -@a = qw(Gold Frankincense Myrrh); -my $ac; -$ac = $o->autochomp(); -expect($ac); -# See if that accidentally changed it -$ac = $o->autochomp(); -expect($ac); -# Now clear it -$ac = $o->autochomp(0); -expect($ac); -expect(join("-", @a), "Gold$:-Frankincense$:-Myrrh$:"); -# Now set it again -$ac = $o->autochomp(1); -expect(!$ac); -expect(join("-", @a), "Gold-Frankincense-Myrrh"); - -# (69) Does 'splice' work correctly with autochomp? -my @sr; -@sr = splice @a, 0, 2; -expect(join("-", @sr), "Gold-Frankincense"); - -# (70-71) Didn't you forget that fetch may return an unchomped cached record? -$a1 = $a[0]; # populate cache -$a2 = $a[0]; -expect($a1, "Myrrh"); -expect($a2, "Myrrh"); -# Actually no, you didn't---_fetch might return such a record, but -# the chomping is done by FETCH. - -use POSIX 'SEEK_SET'; -sub check_contents { - my @c = @_; - my $x = join $:, @c, ''; - local *FH = $o->{fh}; - seek FH, 0, SEEK_SET; -# my $open = open FH, "< $file"; - my $a; - { local $/; $a = <FH> } - $a = "" unless defined $a; - if ($a eq $x) { - print "ok $N\n"; - } else { - ctrlfix($a, $x); - print "not ok $N\n# expected <$x>, got <$a>\n"; - } - $N++; - - # now check FETCH: - my $good = 1; - my $msg; - for (0.. $#c) { - my $aa = $a[$_]; - unless ($aa eq $c[$_]) { - $msg = "expected <$c[$_]>, got <$aa>"; - ctrlfix($msg); - $good = 0; - } - } - print $good ? "ok $N\n" : "not ok $N # $msg\n"; - $N++; - - print $o->_check_integrity($file, $ENV{INTEGRITY}) - ? "ok $N\n" : "not ok $N\n"; - $N++; -} - -sub expect { - if (@_ == 1) { - print $_[0] ? "ok $N\n" : "not ok $N\n"; - } elsif (@_ == 2) { - my ($a, $x) = @_; - if (! defined($a) && ! defined($x)) { print "ok $N\n" } - elsif ( defined($a) && ! defined($x)) { - ctrlfix(my $msg = "expected UNDEF, got <$a>"); - print "not ok $N \# $msg\n"; - } - elsif (! defined($a) && defined($x)) { - ctrlfix(my $msg = "expected <$x>, got UNDEF"); - print "not ok $N \# $msg\n"; - } elsif ($a eq $x) { print "ok $N\n" } - else { - ctrlfix(my $msg = "expected <$x>, got <$a>"); - print "not ok $N \# $msg\n"; - } - } else { - die "expect() got ", scalar(@_), " args, should have been 1 or 2"; - } - $N++; -} - -sub ctrlfix { - for (@_) { - s/\n/\\n/g; - s/\r/\\r/g; - } -} - -END { - undef $o; - untie @a; - 1 while unlink $file; -} - diff --git a/lib/Tie/File/t/23_rv_ac_splice.t b/lib/Tie/File/t/23_rv_ac_splice.t deleted file mode 100644 index be229574f9..0000000000 --- a/lib/Tie/File/t/23_rv_ac_splice.t +++ /dev/null @@ -1,182 +0,0 @@ -#!/usr/bin/perl -# -# Check SPLICE function's return value when autochoping is now -# (07_rv_splice.t checks it aith autochomping off) -# - -my $file = "tf$$.txt"; -$: = Tie::File::_default_recsep(); -my $data = "rec0$:rec1$:rec2$:"; - -print "1..50\n"; - -my $N = 1; -use Tie::File; -print "ok $N\n"; $N++; # partial credit just for showing up - -init_file($data); - -my $o = tie @a, 'Tie::File', $file, autochomp => 1; -print $o ? "ok $N\n" : "not ok $N\n"; -$N++; - -my $n; - -# (3-12) splicing at the beginning -@r = splice(@a, 0, 0, "rec4"); -check_result(); -@r = splice(@a, 0, 1, "rec5"); # same length -check_result("rec4"); -@r = splice(@a, 0, 1, "record5"); # longer -check_result("rec5"); - -@r = splice(@a, 0, 1, "r5"); # shorter -check_result("record5"); -@r = splice(@a, 0, 1); # removal -check_result("r5"); -@r = splice(@a, 0, 0); # no-op -check_result(); -@r = splice(@a, 0, 0, 'r7', 'rec8'); # insert more than one -check_result(); -@r = splice(@a, 0, 2, 'rec7', 'record8', 'rec9'); # insert more than delete -check_result('r7', 'rec8'); - -@r = splice(@a, 0, 3, 'record9', 'rec10'); # delete more than insert -check_result('rec7', 'record8', 'rec9'); -@r = splice(@a, 0, 2); # delete more than one -check_result('record9', 'rec10'); - - -# (13-22) splicing in the middle -@r = splice(@a, 1, 0, "rec4"); -check_result(); -@r = splice(@a, 1, 1, "rec5"); # same length -check_result('rec4'); -@r = splice(@a, 1, 1, "record5"); # longer -check_result('rec5'); - -@r = splice(@a, 1, 1, "r5"); # shorter -check_result("record5"); -@r = splice(@a, 1, 1); # removal -check_result("r5"); -@r = splice(@a, 1, 0); # no-op -check_result(); -@r = splice(@a, 1, 0, 'r7', 'rec8'); # insert more than one -check_result(); -@r = splice(@a, 1, 2, 'rec7', 'record8', 'rec9'); # insert more than delete -check_result('r7', 'rec8'); - -@r = splice(@a, 1, 3, 'record9', 'rec10'); # delete more than insert -check_result('rec7', 'record8', 'rec9'); -@r = splice(@a, 1, 2); # delete more than one -check_result('record9','rec10'); - -# (23-32) splicing at the end -@r = splice(@a, 3, 0, "rec4"); -check_result(); -@r = splice(@a, 3, 1, "rec5"); # same length -check_result('rec4'); -@r = splice(@a, 3, 1, "record5"); # longer -check_result('rec5'); - -@r = splice(@a, 3, 1, "r5"); # shorter -check_result('record5'); -@r = splice(@a, 3, 1); # removal -check_result('r5'); -@r = splice(@a, 3, 0); # no-op -check_result(); -@r = splice(@a, 3, 0, 'r7', 'rec8'); # insert more than one -check_result(); -@r = splice(@a, 3, 2, 'rec7', 'record8', 'rec9'); # insert more than delete -check_result('r7', 'rec8'); - -@r = splice(@a, 3, 3, 'record9', 'rec10'); # delete more than insert -check_result('rec7', 'record8', 'rec9'); -@r = splice(@a, 3, 2); # delete more than one -check_result('record9', 'rec10'); - -# (33-42) splicing with negative subscript -@r = splice(@a, -1, 0, "rec4"); -check_result(); -@r = splice(@a, -1, 1, "rec5"); # same length -check_result('rec2'); -@r = splice(@a, -1, 1, "record5"); # longer -check_result("rec5"); - -@r = splice(@a, -1, 1, "r5"); # shorter -check_result("record5"); -@r = splice(@a, -1, 1); # removal -check_result("r5"); -@r = splice(@a, -1, 0); # no-op -check_result(); -@r = splice(@a, -1, 0, 'r7', 'rec8'); # insert more than one -check_result(); -@r = splice(@a, -1, 2, 'rec7', 'record8', 'rec9'); # insert more than delete -check_result('rec4'); - -@r = splice(@a, -3, 3, 'record9', 'rec10'); # delete more than insert -check_result('rec7', 'record8', 'rec9'); -@r = splice(@a, -4, 3); # delete more than one -check_result('r7', 'rec8', 'record9'); - -# (43) scrub it all out -@r = splice(@a, 0, 3); -check_result('rec0', 'rec1', 'rec10'); - -# (44) put some back in -@r = splice(@a, 0, 0, "rec0", "rec1"); -check_result(); - -# (45) what if we remove too many records? -@r = splice(@a, 0, 17); -check_result('rec0', 'rec1'); - -# (46-48) Now check the scalar context return -splice(@a, 0, 0, qw(I like pie)); -my $r; -$r = splice(@a, 0, 0); -print !defined($r) ? "ok $N\n" : "not ok $N \# return should have been undef, was <$r>\n"; -$N++; - -$r = splice(@a, 2, 1); -print $r eq "pie" ? "ok $N\n" : "not ok $N \# return should have been 'pie', was <$r>\n"; -$N++; - -$r = splice(@a, 0, 2); -print $r eq "like" ? "ok $N\n" : "not ok $N \# return should have been 'like', was <$r>\n"; -$N++; - -# (49-50) Test default arguments -splice @a, 0, 0, (0..11); -@r = splice @a, 4; -check_result(4..11); -@r = splice @a; -check_result(0..3); - -sub init_file { - my $data = shift; - open F, "> $file" or die $!; - binmode F; - print F $data; - close F; -} - -# actual results are in @r. -# expected results are in @_ -sub check_result { - my @x = @_; - my $good = 1; - $good = 0 unless @r == @x; - for my $i (0 .. $#r) { - $good = 0 unless $r[$i] eq $x[$i]; - } - print $good ? "ok $N\n" : "not ok $N \# was (@r); should be (@x)\n"; - $N++; -} - -END { - undef $o; - untie @a; - 1 while unlink $file; -} - diff --git a/lib/Tie/File/t/24_cache_loop.t b/lib/Tie/File/t/24_cache_loop.t deleted file mode 100644 index 0bc66bee2b..0000000000 --- a/lib/Tie/File/t/24_cache_loop.t +++ /dev/null @@ -1,55 +0,0 @@ -#!/usr/bin/perl -# -# Tests for various caching errors -# - -use Config; -my $file = "tf$$.txt"; -unless ($Config{d_alarm}) { - print "1..0\n"; exit; -} - -$: = Tie::File::_default_recsep(); -my $data = join $:, "record0" .. "record9", ""; -my $V = $ENV{INTEGRITY}; # Verbose integrity checking? - -print "1..3\n"; - -my $N = 1; -use Tie::File; -print "ok $N\n"; $N++; - -open F, "> $file" or die $!; -binmode F; -print F $data; -close F; - -# Limit cache size to 30 bytes -my $MAX = 30; -# -- that's enough space for 3 records, but not 4, on both \n and \r\n systems -my $o = tie @a, 'Tie::File', $file, memory => $MAX, autodefer => 1; -print $o ? "ok $N\n" : "not ok $N\n"; -$N++; - -# (3) In 0.50 this goes into an infinite loop. Explanation: -# -# Suppose you overfill the defer buffer by so much that the memory -# limit is also exceeded. You'll go into _splice to prepare to -# write out the defer buffer, and _splice will call _fetch, which -# will then try to flush the read cache---but the read cache is -# already empty, so you're stuck in an infinite loop. -# -# Five seconds should be plenty of time for it to complete if it works. -alarm 5 unless $^P; -@a = "record0" .. "record9"; -print "ok 3\n"; -alarm 0; - -END { - undef $o; - untie @a; - 1 while unlink $file; -} - - - diff --git a/lib/Tie/File/t/25_gen_nocache.t b/lib/Tie/File/t/25_gen_nocache.t deleted file mode 100644 index 78e5506215..0000000000 --- a/lib/Tie/File/t/25_gen_nocache.t +++ /dev/null @@ -1,137 +0,0 @@ -#!/usr/bin/perl -# -# Regular read-write tests with caching disabled -# (Same as 01_gen.t) -# -my $file = "tf$$.txt"; - -print "1..68\n"; - -my $N = 1; -use Tie::File; -print "ok $N\n"; $N++; - -my $o = tie @a, 'Tie::File', $file, autochomp => 0, autodefer => 0, memory => 0; -print $o ? "ok $N\n" : "not ok $N\n"; -$N++; - -$: = $o->{recsep}; - -# 3-5 create -$a[0] = 'rec0'; -check_contents("rec0"); - -# 6-11 append -$a[1] = 'rec1'; -check_contents("rec0", "rec1"); -$a[2] = 'rec2'; -check_contents("rec0", "rec1", "rec2"); - -# 12-20 same-length alterations -$a[0] = 'new0'; -check_contents("new0", "rec1", "rec2"); -$a[1] = 'new1'; -check_contents("new0", "new1", "rec2"); -$a[2] = 'new2'; -check_contents("new0", "new1", "new2"); - -# 21-35 lengthening alterations -$a[0] = 'long0'; -check_contents("long0", "new1", "new2"); -$a[1] = 'long1'; -check_contents("long0", "long1", "new2"); -$a[2] = 'long2'; -check_contents("long0", "long1", "long2"); -$a[1] = 'longer1'; -check_contents("long0", "longer1", "long2"); -$a[0] = 'longer0'; -check_contents("longer0", "longer1", "long2"); - -# 36-50 shortening alterations, including truncation -$a[0] = 'short0'; -check_contents("short0", "longer1", "long2"); -$a[1] = 'short1'; -check_contents("short0", "short1", "long2"); -$a[2] = 'short2'; -check_contents("short0", "short1", "short2"); -$a[1] = 'sh1'; -check_contents("short0", "sh1", "short2"); -$a[0] = 'sh0'; -check_contents("sh0", "sh1", "short2"); - -# (51-56) file with holes -$a[4] = 'rec4'; -check_contents("sh0", "sh1", "short2", "", "rec4"); -$a[3] = 'rec3'; -check_contents("sh0", "sh1", "short2", "rec3", "rec4"); - -# (57-59) zero out file -@a = (); -check_contents(); - -# (60-62) insert into the middle of an empty file -$a[3] = "rec3"; -check_contents("", "", "", "rec3"); - -# (63-68) 20020326 You thought there would be a bug in STORE where if -# a cached record was false, STORE wouldn't see it at all. But you -# forgot that records always come back from the cache with the record -# separator attached, so they are unlikely to be false. The only -# really weird case is when the cached record is empty and the record -# separator is "0". Test that in 09_gen_rs.t. -$a[1] = "0"; -check_contents("", "0", "", "rec3"); -$a[1] = "whoops"; -check_contents("", "whoops", "", "rec3"); - - -use POSIX 'SEEK_SET'; -sub check_contents { - my @c = @_; - my $x = join $:, @c, ''; - local *FH = $o->{fh}; - seek FH, 0, SEEK_SET; -# my $open = open FH, "< $file"; - my $a; - { local $/; $a = <FH> } - $a = "" unless defined $a; - if ($a eq $x) { - print "ok $N\n"; - } else { - ctrlfix($a, $x); - print "not ok $N\n# expected <$x>, got <$a>\n"; - } - $N++; - - # now check FETCH: - my $good = 1; - my $msg; - for (0.. $#c) { - my $aa = $a[$_]; - unless ($aa eq "$c[$_]$:") { - $msg = "expected <$c[$_]$:>, got <$aa>"; - ctrlfix($msg); - $good = 0; - } - } - print $good ? "ok $N\n" : "not ok $N # $msg\n"; - $N++; - - print $o->_check_integrity($file, $ENV{INTEGRITY}) - ? "ok $N\n" : "not ok $N\n"; - $N++; -} - -sub ctrlfix { - for (@_) { - s/\n/\\n/g; - s/\r/\\r/g; - } -} - -END { - undef $o; - untie @a; - 1 while unlink $file; -} - diff --git a/lib/Tie/File/t/26_twrite.t b/lib/Tie/File/t/26_twrite.t deleted file mode 100644 index e2a925f4e0..0000000000 --- a/lib/Tie/File/t/26_twrite.t +++ /dev/null @@ -1,359 +0,0 @@ -#!/usr/bin/perl -# -# Unit tests of _twrite function -# -# _twrite($self, $data, $pos, $len) -# -# 't' here is for 'tail'. This writes $data at absolute position $pos -# in the file, overwriting exactly $len of the bytes at that position. -# Everything else is moved down or up, dependong on whether -# length($data) > $len or length($data) < $len. -# $len == 0 is a pure insert; $len == length($data) is a simple overwrite. -# - -my $file = "tf$$.txt"; - -print "1..181\n"; - -my $N = 1; -use Tie::File; -print "ok $N\n"; $N++; - -$: = Tie::File::_default_recsep(); - -# (2) Peter Scott sent this one. It fails in 0.51 and works in 0.90 -# <4.3.2.7.2.20020331102819.00b913d0@shell2.webquarry.com> -# -# The problem was premature termination in the inner loop -# because you had $more_data scoped *inside* the block instead of outside. -# 20020331 -open F, "> $file" or die "Couldn't open $file: $!"; -binmode F; -for (1..100) { - print F "$_ ", 'a'x150, $: ; -} -close F; -# The file is now 15292 characters long on Unix, 15392 on Win32 -die -s $file unless -s $file == 15292 + 100 * length($:); - -tie my @lines, 'Tie::File', $file or die $!; -push @lines, "1001 ".('a' x 100); -splice @lines, 0, 1; -untie @lines; - -my $s = -s $file; -my $x = 15292 - 152 + 105 + 100*length($:); -print $s == $x - ? "ok $N\n" : "not ok $N # expected $x, got $s\n"; -$N++; - -my @subtests = qw(x <x x> x><x <x> <x><x x><x> <x><x> <x><x><x> 0); - -# (3-73) These were generated by 'gentests.pl' to cover all possible cases -# (I hope) -# Legend: -# x: data is entirely contained within one block -# x>: data runs from the middle to the end of the block -# <x: data runs from the start to the middle of the block -# <x>: data occupies precisely one block -# x><x: data overlaps one block boundary -# <x><x: data runs from the start of one block into the middle of the next -# x><x>: data runs from the middle of one block to the end of the next -# <x><x>: data occupies two blocks exactly -# <x><x><x>: data occupies three blocks exactly -# 0: data is null -# -# For each possible alignment of the old and new data, we investigate -# up to three situations: old data is shorter, old and new data are the -# same length, and new data is shorter. -# -# try($pos, $old, $new) means to run a test where the data starts at -# position $pos, the old data has length $old, -# and the new data has length $new. -try( 9659, 6635, 6691); # old=x , new=x ; old < new -try( 8605, 2394, 2394); # old=x , new=x ; old = new -try( 9768, 1361, 664); # old=x , new=x ; old > new -try( 9955, 6429, 6429); # old=x> , new=x ; old = new -try(10550, 5834, 4123); # old=x> , new=x ; old > new -try(14580, 6158, 851); # old=x><x , new=x ; old > new -try(13442, 11134, 1572); # old=x><x> , new=x ; old > new -try( 8394, 0, 5742); # old=0 , new=x ; old < new -try( 8192, 2819, 6738); # old=<x , new=<x ; old < new -try( 8192, 514, 514); # old=<x , new=<x ; old = new -try( 8192, 2196, 858); # old=<x , new=<x ; old > new -try( 8192, 8192, 8192); # old=<x> , new=<x ; old = new -try( 8192, 8192, 1290); # old=<x> , new=<x ; old > new -try( 8192, 10575, 6644); # old=<x><x , new=<x ; old > new -try( 8192, 16384, 5616); # old=<x><x> , new=<x ; old > new -try( 8192, 24576, 6253); # old=<x><x><x>, new=<x ; old > new -try( 8192, 0, 6870); # old=0 , new=<x ; old < new -try( 8478, 6259, 7906); # old=x , new=x> ; old < new -try( 9965, 6419, 6419); # old=x> , new=x> ; old = new -try(16059, 6102, 325); # old=x><x , new=x> ; old > new -try( 9503, 15073, 6881); # old=x><x> , new=x> ; old > new -try( 9759, 0, 6625); # old=0 , new=x> ; old < new -try( 8525, 2081, 8534); # old=x , new=x><x ; old < new -try(15550, 834, 1428); # old=x> , new=x><x ; old < new -try(14966, 1668, 3479); # old=x><x , new=x><x ; old < new -try(16316, 1605, 1605); # old=x><x , new=x><x ; old = new -try(16093, 4074, 993); # old=x><x , new=x><x ; old > new -try(14739, 9837, 9837); # old=x><x> , new=x><x ; old = new -try(14071, 10505, 7344); # old=x><x> , new=x><x ; old > new -try(12602, 0, 8354); # old=0 , new=x><x ; old < new -try( 8192, 2767, 8192); # old=<x , new=<x> ; old < new -try( 8192, 8192, 8192); # old=<x> , new=<x> ; old = new -try( 8192, 14817, 8192); # old=<x><x , new=<x> ; old > new -try( 8192, 16384, 8192); # old=<x><x> , new=<x> ; old > new -try( 8192, 24576, 8192); # old=<x><x><x>, new=<x> ; old > new -try( 8192, 0, 8192); # old=0 , new=<x> ; old < new -try( 8192, 6532, 10882); # old=<x , new=<x><x ; old < new -try( 8192, 8192, 16044); # old=<x> , new=<x><x ; old < new -try( 8192, 9555, 11020); # old=<x><x , new=<x><x ; old < new -try( 8192, 9001, 9001); # old=<x><x , new=<x><x ; old = new -try( 8192, 11760, 10274); # old=<x><x , new=<x><x ; old > new -try( 8192, 16384, 10781); # old=<x><x> , new=<x><x ; old > new -try( 8192, 24576, 9284); # old=<x><x><x>, new=<x><x ; old > new -try( 8192, 0, 12488); # old=0 , new=<x><x ; old < new -try( 8222, 6385, 16354); # old=x , new=x><x> ; old < new -try(13500, 2884, 11076); # old=x> , new=x><x> ; old < new -try(14069, 4334, 10507); # old=x><x , new=x><x> ; old < new -try(14761, 9815, 9815); # old=x><x> , new=x><x> ; old = new -try(10469, 0, 14107); # old=0 , new=x><x> ; old < new -try( 8192, 4181, 16384); # old=<x , new=<x><x> ; old < new -try( 8192, 8192, 16384); # old=<x> , new=<x><x> ; old < new -try( 8192, 12087, 16384); # old=<x><x , new=<x><x> ; old < new -try( 8192, 16384, 16384); # old=<x><x> , new=<x><x> ; old = new -try( 8192, 24576, 16384); # old=<x><x><x>, new=<x><x> ; old > new -try( 8192, 0, 16384); # old=0 , new=<x><x> ; old < new -try( 8192, 4968, 24576); # old=<x , new=<x><x><x>; old < new -try( 8192, 8192, 24576); # old=<x> , new=<x><x><x>; old < new -try( 8192, 14163, 24576); # old=<x><x , new=<x><x><x>; old < new -try( 8192, 16384, 24576); # old=<x><x> , new=<x><x><x>; old < new -try( 8192, 24576, 24576); # old=<x><x><x>, new=<x><x><x>; old = new -try( 8192, 0, 24576); # old=0 , new=<x><x><x>; old < new -try( 8771, 776, 0); # old=x , new=0 ; old > new -try( 8192, 2813, 0); # old=<x , new=0 ; old > new -try(13945, 2439, 0); # old=x> , new=0 ; old > new -try(14493, 6090, 0); # old=x><x , new=0 ; old > new -try( 8192, 8192, 0); # old=<x> , new=0 ; old > new -try( 8192, 10030, 0); # old=<x><x , new=0 ; old > new -try(14983, 9593, 0); # old=x><x> , new=0 ; old > new -try( 8192, 16384, 0); # old=<x><x> , new=0 ; old > new -try( 8192, 24576, 0); # old=<x><x><x>, new=0 ; old > new -try(10489, 0, 0); # old=0 , new=0 ; old = new - -# (74-114) -# These tests all take place at the start of the file -try( 0, 771, 1593); # old=<x , new=<x ; old < new -try( 0, 4868, 4868); # old=<x , new=<x ; old = new -try( 0, 147, 118); # old=<x , new=<x ; old > new -try( 0, 8192, 8192); # old=<x> , new=<x ; old = new -try( 0, 8192, 4574); # old=<x> , new=<x ; old > new -try( 0, 11891, 1917); # old=<x><x , new=<x ; old > new -try( 0, 16384, 5155); # old=<x><x> , new=<x ; old > new -try( 0, 24576, 2953); # old=<x><x><x>, new=<x ; old > new -try( 0, 0, 1317); # old=0 , new=<x ; old < new -try( 0, 5609, 8192); # old=<x , new=<x> ; old < new -try( 0, 8192, 8192); # old=<x> , new=<x> ; old = new -try( 0, 11083, 8192); # old=<x><x , new=<x> ; old > new -try( 0, 16384, 8192); # old=<x><x> , new=<x> ; old > new -try( 0, 24576, 8192); # old=<x><x><x>, new=<x> ; old > new -try( 0, 0, 8192); # old=0 , new=<x> ; old < new -try( 0, 6265, 9991); # old=<x , new=<x><x ; old < new -try( 0, 8192, 16119); # old=<x> , new=<x><x ; old < new -try( 0, 10218, 11888); # old=<x><x , new=<x><x ; old < new -try( 0, 14126, 14126); # old=<x><x , new=<x><x ; old = new -try( 0, 12002, 9034); # old=<x><x , new=<x><x ; old > new -try( 0, 16384, 13258); # old=<x><x> , new=<x><x ; old > new -try( 0, 24576, 14367); # old=<x><x><x>, new=<x><x ; old > new -try( 0, 0, 10881); # old=0 , new=<x><x ; old < new -try( 0, 6448, 16384); # old=<x , new=<x><x> ; old < new -try( 0, 8192, 16384); # old=<x> , new=<x><x> ; old < new -try( 0, 15082, 16384); # old=<x><x , new=<x><x> ; old < new -try( 0, 16384, 16384); # old=<x><x> , new=<x><x> ; old = new -try( 0, 24576, 16384); # old=<x><x><x>, new=<x><x> ; old > new -try( 0, 0, 16384); # old=0 , new=<x><x> ; old < new -try( 0, 2421, 24576); # old=<x , new=<x><x><x>; old < new -try( 0, 8192, 24576); # old=<x> , new=<x><x><x>; old < new -try( 0, 11655, 24576); # old=<x><x , new=<x><x><x>; old < new -try( 0, 16384, 24576); # old=<x><x> , new=<x><x><x>; old < new -try( 0, 24576, 24576); # old=<x><x><x>, new=<x><x><x>; old = new -try( 0, 0, 24576); # old=0 , new=<x><x><x>; old < new -try( 0, 6530, 0); # old=<x , new=0 ; old > new -try( 0, 8192, 0); # old=<x> , new=0 ; old > new -try( 0, 14707, 0); # old=<x><x , new=0 ; old > new -try( 0, 16384, 0); # old=<x><x> , new=0 ; old > new -try( 0, 24576, 0); # old=<x><x><x>, new=0 ; old > new -try( 0, 0, 0); # old=0 , new=0 ; old = new - -# (115-141) -# These tests all take place at the end of the file -$FLEN = 40960; # Force the file to be exactly 40960 bytes long -try(32768, 8192, 8192); # old=<x> , new=<x ; old = new -try(32768, 8192, 4026); # old=<x> , new=<x ; old > new -try(24576, 16384, 1917); # old=<x><x> , new=<x ; old > new -try(16384, 24576, 3818); # old=<x><x><x>, new=<x ; old > new -try(40960, 0, 2779); # old=0 , new=<x ; old < new -try(32768, 8192, 8192); # old=<x> , new=<x> ; old = new -try(24576, 16384, 8192); # old=<x><x> , new=<x> ; old > new -try(16384, 24576, 8192); # old=<x><x><x>, new=<x> ; old > new -try(40960, 0, 8192); # old=0 , new=<x> ; old < new -try(32768, 8192, 10724); # old=<x> , new=<x><x ; old < new -try(24576, 16384, 12221); # old=<x><x> , new=<x><x ; old > new -try(16384, 24576, 15030); # old=<x><x><x>, new=<x><x ; old > new -try(40960, 0, 11752); # old=0 , new=<x><x ; old < new -try(32768, 8192, 16384); # old=<x> , new=<x><x> ; old < new -try(24576, 16384, 16384); # old=<x><x> , new=<x><x> ; old = new -try(16384, 24576, 16384); # old=<x><x><x>, new=<x><x> ; old > new -try(40960, 0, 16384); # old=0 , new=<x><x> ; old < new -try(32768, 8192, 24576); # old=<x> , new=<x><x><x>; old < new -try(24576, 16384, 24576); # old=<x><x> , new=<x><x><x>; old < new -try(16384, 24576, 24576); # old=<x><x><x>, new=<x><x><x>; old = new -try(40960, 0, 24576); # old=0 , new=<x><x><x>; old < new -try(35973, 4987, 0); # old=x> , new=0 ; old > new -try(32768, 8192, 0); # old=<x> , new=0 ; old > new -try(29932, 11028, 0); # old=x><x> , new=0 ; old > new -try(24576, 16384, 0); # old=<x><x> , new=0 ; old > new -try(16384, 24576, 0); # old=<x><x><x>, new=0 ; old > new -try(40960, 0, 0); # old=0 , new=0 ; old = new - -# (142-181) -# These tests all take place at the end of the file -$FLEN = 42000; # Force the file to be exactly 42000 bytes long -try(41275, 725, 4059); # old=x , new=x ; old < new -try(41683, 317, 317); # old=x , new=x ; old = new -try(41225, 775, 405); # old=x , new=x ; old > new -try(35709, 6291, 284); # old=x><x , new=x ; old > new -try(42000, 0, 2434); # old=0 , new=x ; old < new -try(40960, 1040, 1608); # old=<x , new=<x ; old < new -try(40960, 1040, 1040); # old=<x , new=<x ; old = new -try(40960, 1040, 378); # old=<x , new=<x ; old > new -try(32768, 9232, 5604); # old=<x><x , new=<x ; old > new -try(42000, 0, 6637); # old=0 , new=<x ; old < new -try(41022, 978, 8130); # old=x , new=x> ; old < new -try(39994, 2006, 966); # old=x><x , new=x> ; old > new -try(42000, 0, 7152); # old=0 , new=x> ; old < new -try(41613, 387, 10601); # old=x , new=x><x ; old < new -try(38460, 3540, 3938); # old=x><x , new=x><x ; old < new -try(36725, 5275, 5275); # old=x><x , new=x><x ; old = new -try(37990, 4010, 3199); # old=x><x , new=x><x ; old > new -try(42000, 0, 9189); # old=0 , new=x><x ; old < new -try(40960, 1040, 8192); # old=<x , new=<x> ; old < new -try(32768, 9232, 8192); # old=<x><x , new=<x> ; old > new -try(42000, 0, 8192); # old=0 , new=<x> ; old < new -try(40960, 1040, 11778); # old=<x , new=<x><x ; old < new -try(32768, 9232, 13792); # old=<x><x , new=<x><x ; old < new -try(32768, 9232, 9232); # old=<x><x , new=<x><x ; old = new -try(32768, 9232, 8795); # old=<x><x , new=<x><x ; old > new -try(42000, 0, 8578); # old=0 , new=<x><x ; old < new -try(41531, 469, 15813); # old=x , new=x><x> ; old < new -try(39618, 2382, 9534); # old=x><x , new=x><x> ; old < new -try(42000, 0, 15344); # old=0 , new=x><x> ; old < new -try(40960, 1040, 16384); # old=<x , new=<x><x> ; old < new -try(32768, 9232, 16384); # old=<x><x , new=<x><x> ; old < new -try(42000, 0, 16384); # old=0 , new=<x><x> ; old < new -try(40960, 1040, 24576); # old=<x , new=<x><x><x>; old < new -try(32768, 9232, 24576); # old=<x><x , new=<x><x><x>; old < new -try(42000, 0, 24576); # old=0 , new=<x><x><x>; old < new -try(41500, 500, 0); # old=x , new=0 ; old > new -try(40960, 1040, 0); # old=<x , new=0 ; old > new -try(35272, 6728, 0); # old=x><x , new=0 ; old > new -try(32768, 9232, 0); # old=<x><x , new=0 ; old > new -try(42000, 0, 0); # old=0 , new=0 ; old = new - -sub try { - my ($pos, $len, $newlen) = @_; - open F, "> $file" or die "Couldn't open file $file: $!"; - binmode F; - - # The record has exactly 17 characters. This will help ensure that - # even if _twrite screws up, the data doesn't coincidentally - # look good because the remainder accidentally lines up. - my $d = substr("0123456789abcdef$:", -17); - my $recs = defined($FLEN) ? - int($FLEN/length($d))+1 : # enough to make up at least $FLEN - int(8192*5/length($d))+1; # at least 5 blocks' worth - my $oldfile = $d x $recs; - my $flen = defined($FLEN) ? $FLEN : $recs * 17; - substr($oldfile, $FLEN) = "" if defined $FLEN; # truncate - print F $oldfile; - close F; - - die "wrong length!" unless -s $file == $flen; - - my $newdata = "-" x $newlen; - my $expected = $oldfile; - substr($expected, $pos, $len) = $newdata; - - my $o = tie my @lines, 'Tie::File', $file or die $!; - $o->_twrite($newdata, $pos, $len); - undef $o; untie @lines; - - open F, "< $file" or die "Couldn't open file $file: $!"; - binmode F; - my $actual; - { local $/; - $actual = <F>; - } - close F; - - my ($alen, $xlen) = (length $actual, length $expected); - unless ($alen == $xlen) { - print "# try(@_) expected file length $xlen, actual $alen!\n"; - } - print $actual eq $expected ? "ok $N\n" : "not ok $N\n"; - $N++; -} - - - -use POSIX 'SEEK_SET'; -sub check_contents { - my @c = @_; - my $x = join $:, @c, ''; - local *FH = $o->{fh}; - seek FH, 0, SEEK_SET; -# my $open = open FH, "< $file"; - my $a; - { local $/; $a = <FH> } - $a = "" unless defined $a; - if ($a eq $x) { - print "ok $N\n"; - } else { - ctrlfix($a, $x); - print "not ok $N\n# expected <$x>, got <$a>\n"; - } - $N++; - - # now check FETCH: - my $good = 1; - my $msg; - for (0.. $#c) { - my $aa = $a[$_]; - unless ($aa eq "$c[$_]$:") { - $msg = "expected <$c[$_]$:>, got <$aa>"; - ctrlfix($msg); - $good = 0; - } - } - print $good ? "ok $N\n" : "not ok $N # $msg\n"; - $N++; - - print $o->_check_integrity($file, $ENV{INTEGRITY}) - ? "ok $N\n" : "not ok $N\n"; - $N++; -} - -sub ctrlfix { - for (@_) { - s/\n/\\n/g; - s/\r/\\r/g; - } -} - -END { - undef $o; - untie @a; - 1 while unlink $file; -} - diff --git a/lib/Tie/File/t/27_iwrite.t b/lib/Tie/File/t/27_iwrite.t deleted file mode 100644 index db591a81ba..0000000000 --- a/lib/Tie/File/t/27_iwrite.t +++ /dev/null @@ -1,235 +0,0 @@ -#!/usr/bin/perl -# -# Unit tests of _iwrite function -# -# _iwrite($self, $data, $start, $end) -# -# 'i' here is for 'insert'. This writes $data at absolute position $start -# in the file, copying the data at that position downwards--- -# but only down to position $end. Data at or past $end is not moved -# or even examined. Since there isn't enough room for the full copy -# (Because we inserted $data at the beginning) we copy as much as possible -# and return a string containing the remainder. - -my $file = "tf$$.txt"; -$| = 1; - -print "1..203\n"; - -my $N = 1; -my $oldfile; -use Tie::File; -print "ok $N\n"; $N++; - -$: = Tie::File::_default_recsep(); - -$FLEN = 40970; # Use files of this length -$oldfile = mkrand($FLEN); -print "# MOF tests\n"; -# (2-85) These were generated by 'gentests.pl' to cover all possible cases -# (I hope) -# Legend: -# x: data is entirely contained within one block -# x>: data runs from the middle to the end of the block -# <x: data runs from the start to the middle of the block -# <x>: data occupies precisely one block -# x><x: data overlaps one block boundary -# <x><x: data runs from the start of one block into the middle of the next -# x><x>: data runs from the middle of one block to the end of the next -# <x><x>: data occupies two blocks exactly -# <x><x><x>: data occupies three blocks exactly -# 0: data is null -# -# For each possible alignment of the old and new data, we investigate -# up to three situations: old data is shorter, old and new data are the -# same length, and new data is shorter. -# -# try($pos, $old, $new) means to run a test where the area being -# written into starts at position $pos, the area being written into -# has length $old, and and the new data has length $new. -try( 8605, 2394, 2394); # old=x , new=x ; old = new -try( 9768, 1361, 664); # old=x , new=x ; old > new -try( 9955, 6429, 6429); # old=x> , new=x ; old = new -try(10550, 5834, 4123); # old=x> , new=x ; old > new -try(14580, 6158, 851); # old=x><x , new=x ; old > new -try(13442, 11134, 1572); # old=x><x> , new=x ; old > new -try( 8192, 514, 514); # old=<x , new=<x ; old = new -try( 8192, 2196, 858); # old=<x , new=<x ; old > new -try( 8192, 8192, 8192); # old=<x> , new=<x ; old = new -try( 8192, 8192, 1290); # old=<x> , new=<x ; old > new -try( 8192, 10575, 6644); # old=<x><x , new=<x ; old > new -try( 8192, 16384, 5616); # old=<x><x> , new=<x ; old > new -try( 8192, 24576, 6253); # old=<x><x><x>, new=<x ; old > new -try( 9965, 6419, 6419); # old=x> , new=x> ; old = new -try(16059, 6102, 325); # old=x><x , new=x> ; old > new -try( 9503, 15073, 6881); # old=x><x> , new=x> ; old > new -try(16316, 1605, 1605); # old=x><x , new=x><x ; old = new -try(16093, 4074, 993); # old=x><x , new=x><x ; old > new -try(14739, 9837, 9837); # old=x><x> , new=x><x ; old = new -try(14071, 10505, 7344); # old=x><x> , new=x><x ; old > new -try( 8192, 8192, 8192); # old=<x> , new=<x> ; old = new -try( 8192, 14817, 8192); # old=<x><x , new=<x> ; old > new -try( 8192, 16384, 8192); # old=<x><x> , new=<x> ; old > new -try( 8192, 24576, 8192); # old=<x><x><x>, new=<x> ; old > new -try( 8192, 9001, 9001); # old=<x><x , new=<x><x ; old = new -try( 8192, 11760, 10274); # old=<x><x , new=<x><x ; old > new -try( 8192, 16384, 10781); # old=<x><x> , new=<x><x ; old > new -try( 8192, 24576, 9284); # old=<x><x><x>, new=<x><x ; old > new -try(14761, 9815, 9815); # old=x><x> , new=x><x> ; old = new -try( 8192, 16384, 16384); # old=<x><x> , new=<x><x> ; old = new -try( 8192, 24576, 16384); # old=<x><x><x>, new=<x><x> ; old > new -try( 8192, 24576, 24576); # old=<x><x><x>, new=<x><x><x>; old = new -try( 8771, 776, 0); # old=x , new=0 ; old > new -try( 8192, 2813, 0); # old=<x , new=0 ; old > new -try(13945, 2439, 0); # old=x> , new=0 ; old > new -try(14493, 6090, 0); # old=x><x , new=0 ; old > new -try( 8192, 8192, 0); # old=<x> , new=0 ; old > new -try( 8192, 10030, 0); # old=<x><x , new=0 ; old > new -try(14983, 9593, 0); # old=x><x> , new=0 ; old > new -try( 8192, 16384, 0); # old=<x><x> , new=0 ; old > new -try( 8192, 24576, 0); # old=<x><x><x>, new=0 ; old > new -try(10489, 0, 0); # old=0 , new=0 ; old = new - -print "# SOF tests\n"; -# (86-133) -# These tests all take place at the start of the file -try( 0, 4868, 4868); # old=<x , new=<x ; old = new -try( 0, 147, 118); # old=<x , new=<x ; old > new -try( 0, 8192, 8192); # old=<x> , new=<x ; old = new -try( 0, 8192, 4574); # old=<x> , new=<x ; old > new -try( 0, 11891, 1917); # old=<x><x , new=<x ; old > new -try( 0, 16384, 5155); # old=<x><x> , new=<x ; old > new -try( 0, 24576, 2953); # old=<x><x><x>, new=<x ; old > new -try( 0, 8192, 8192); # old=<x> , new=<x> ; old = new -try( 0, 11083, 8192); # old=<x><x , new=<x> ; old > new -try( 0, 16384, 8192); # old=<x><x> , new=<x> ; old > new -try( 0, 24576, 8192); # old=<x><x><x>, new=<x> ; old > new -try( 0, 14126, 14126); # old=<x><x , new=<x><x ; old = new -try( 0, 12002, 9034); # old=<x><x , new=<x><x ; old > new -try( 0, 16384, 13258); # old=<x><x> , new=<x><x ; old > new -try( 0, 24576, 14367); # old=<x><x><x>, new=<x><x ; old > new -try( 0, 16384, 16384); # old=<x><x> , new=<x><x> ; old = new -try( 0, 24576, 16384); # old=<x><x><x>, new=<x><x> ; old > new -try( 0, 24576, 24576); # old=<x><x><x>, new=<x><x><x>; old = new -try( 0, 6530, 0); # old=<x , new=0 ; old > new -try( 0, 8192, 0); # old=<x> , new=0 ; old > new -try( 0, 14707, 0); # old=<x><x , new=0 ; old > new -try( 0, 16384, 0); # old=<x><x> , new=0 ; old > new -try( 0, 24576, 0); # old=<x><x><x>, new=0 ; old > new -try( 0, 0, 0); # old=0 , new=0 ; old = new - -print "# EOF tests 1\n"; -# (134-169) -# These tests all take place at the end of the file -$FLEN = 40960; # Force the file to be exactly 40960 bytes long -$oldfile = mkrand($FLEN); -try(32768, 8192, 8192); # old=<x> , new=<x ; old = new -try(32768, 8192, 4026); # old=<x> , new=<x ; old > new -try(24576, 16384, 1917); # old=<x><x> , new=<x ; old > new -try(16384, 24576, 3818); # old=<x><x><x>, new=<x ; old > new -try(32768, 8192, 8192); # old=<x> , new=<x> ; old = new -try(24576, 16384, 8192); # old=<x><x> , new=<x> ; old > new -try(16384, 24576, 8192); # old=<x><x><x>, new=<x> ; old > new -try(24576, 16384, 12221); # old=<x><x> , new=<x><x ; old > new -try(16384, 24576, 15030); # old=<x><x><x>, new=<x><x ; old > new -try(24576, 16384, 16384); # old=<x><x> , new=<x><x> ; old = new -try(16384, 24576, 16384); # old=<x><x><x>, new=<x><x> ; old > new -try(16384, 24576, 24576); # old=<x><x><x>, new=<x><x><x>; old = new -try(35973, 4987, 0); # old=x> , new=0 ; old > new -try(32768, 8192, 0); # old=<x> , new=0 ; old > new -try(29932, 11028, 0); # old=x><x> , new=0 ; old > new -try(24576, 16384, 0); # old=<x><x> , new=0 ; old > new -try(16384, 24576, 0); # old=<x><x><x>, new=0 ; old > new -try(40960, 0, 0); # old=0 , new=0 ; old = new - -print "# EOF tests 2\n"; -# (170-203) -# These tests all take place at the end of the file -$FLEN = 42000; # Force the file to be exactly 42000 bytes long -$oldfile = mkrand($FLEN); -try(41683, 317, 317); # old=x , new=x ; old = new -try(41225, 775, 405); # old=x , new=x ; old > new -try(35709, 6291, 284); # old=x><x , new=x ; old > new -try(40960, 1040, 1040); # old=<x , new=<x ; old = new -try(40960, 1040, 378); # old=<x , new=<x ; old > new -try(32768, 9232, 5604); # old=<x><x , new=<x ; old > new -try(39994, 2006, 966); # old=x><x , new=x> ; old > new -try(36725, 5275, 5275); # old=x><x , new=x><x ; old = new -try(37990, 4010, 3199); # old=x><x , new=x><x ; old > new -try(32768, 9232, 8192); # old=<x><x , new=<x> ; old > new -try(32768, 9232, 9232); # old=<x><x , new=<x><x ; old = new -try(32768, 9232, 8795); # old=<x><x , new=<x><x ; old > new -try(41500, 500, 0); # old=x , new=0 ; old > new -try(40960, 1040, 0); # old=<x , new=0 ; old > new -try(35272, 6728, 0); # old=x><x , new=0 ; old > new -try(32768, 9232, 0); # old=<x><x , new=0 ; old > new -try(42000, 0, 0); # old=0 , new=0 ; old = new - -sub mkrand { - my $len = shift; - srand $len; - my @c = ('a' .. 'z', 'A' .. 'Z', 0..9, $:); - my $d = ""; - $d .= $c[rand @c] until length($d) >= $len; - substr($d, $len) = ""; # chop it off to the proper length - $d; -} - -sub try { - my ($s, $len, $newlen) = @_; - my $e = $s + $len; - - open F, "> $file" or die "Couldn't open file $file: $!"; - binmode F; - - print F $oldfile; - close F; - - die "wrong length!" unless -s $file == $FLEN; - - my $newdata = "-" x $newlen; - my $expected = $oldfile; - - my $expected_return = substr($expected, $e - $newlen, $newlen, ""); - substr($expected, $s, 0, $newdata); - - my $o = tie my @lines, 'Tie::File', $file or die $!; - my $actual_return = $o->_iwrite($newdata, $s, $e); - undef $o; untie @lines; - - open F, "< $file" or die "Couldn't open file $file: $!"; - binmode F; - my $actual; - { local $/; - $actual = <F>; - } - close F; - - my ($alen, $xlen) = (length $actual, length $expected); - unless ($alen == $xlen) { - print "# try(@_) expected file length $xlen, actual $alen!\n"; - } - print $actual eq $expected ? "ok $N\n" : "not ok $N\n"; - $N++; - - if (! defined $actual_return && ! defined $expected_return) { - print "ok $N\n"; - } elsif (! defined $actual_return || ! defined $expected_return) { - print "not ok $N\n"; - } else { - print $actual_return eq $expected_return ? "ok $N\n" : "not ok $N\n"; - } - $N++; -} - -sub ctrlfix { - for (@_) { - s/\n/\\n/g; - s/\r/\\r/g; - } -} - -END { - 1 while unlink $file; -} - diff --git a/lib/Tie/File/t/28_mtwrite.t b/lib/Tie/File/t/28_mtwrite.t deleted file mode 100644 index 50e306d3b6..0000000000 --- a/lib/Tie/File/t/28_mtwrite.t +++ /dev/null @@ -1,295 +0,0 @@ -#!/usr/bin/perl -# -# Unit tests of _mtwrite function -# -# _mtwrite($self, $d1, $s1, $l1, $d2, $s2, $l2, ...) -# -# 'm' here is for 'multiple'. This writes data $d1 at position $s1 -# over a block of space $l1, moving subsequent data up or down as necessary. - -my $file = "tf$$.txt"; -$| = 1; - -print "1..2252\n"; - -my $N = 1; -my $oldfile; -use Tie::File; -print "ok $N\n"; $N++; - -$: = Tie::File::_default_recsep(); - -# Only these are used for the triple-region tests -@BASE_TRIES = ( - [10, 20, 30], - [10, 30, 20], - [100, 30, 20], - [100, 20, 30], - [100, 40, 20], - [100, 20, 40], - [200, 20, 30], - [200, 30, 20], - [200, 20, 60], - [200, 60, 20], - ); - -@TRIES = @BASE_TRIES; - -$FLEN = 40970; # Use files of this length -$oldfile = mkrand($FLEN); -print "# MOF tests\n"; -# These were generated by 'gentests.pl' to cover all possible cases -# (I hope) -# Legend: -# x: data is entirely contained within one block -# x>: data runs from the middle to the end of the block -# <x: data runs from the start to the middle of the block -# <x>: data occupies precisely one block -# x><x: data overlaps one block boundary -# <x><x: data runs from the start of one block into the middle of the next -# x><x>: data runs from the middle of one block to the end of the next -# <x><x>: data occupies two blocks exactly -# <x><x><x>: data occupies three blocks exactly -# 0: data is null -# -# For each possible alignment of the old and new data, we investigate -# up to three situations: old data is shorter, old and new data are the -# same length, and new data is shorter. -# -# try($pos, $old, $new) means to run a test where the area being -# written into starts at position $pos, the area being written into -# has length $old, and and the new data has length $new. -try( 8605, 2394, 2394); # old=x , new=x ; old = new -try( 9768, 1361, 664); # old=x , new=x ; old > new -try( 9955, 6429, 6429); # old=x> , new=x ; old = new -try(10550, 5834, 4123); # old=x> , new=x ; old > new -try(14580, 6158, 851); # old=x><x , new=x ; old > new -try(13442, 11134, 1572); # old=x><x> , new=x ; old > new -try( 8192, 514, 514); # old=<x , new=<x ; old = new -try( 8192, 2196, 858); # old=<x , new=<x ; old > new -try( 8192, 8192, 8192); # old=<x> , new=<x ; old = new -try( 8192, 8192, 1290); # old=<x> , new=<x ; old > new -try( 8192, 10575, 6644); # old=<x><x , new=<x ; old > new -try( 8192, 16384, 5616); # old=<x><x> , new=<x ; old > new -try( 8192, 24576, 6253); # old=<x><x><x>, new=<x ; old > new -try( 9965, 6419, 6419); # old=x> , new=x> ; old = new -try(16059, 6102, 325); # old=x><x , new=x> ; old > new -try( 9503, 15073, 6881); # old=x><x> , new=x> ; old > new -try(16316, 1605, 1605); # old=x><x , new=x><x ; old = new -try(16093, 4074, 993); # old=x><x , new=x><x ; old > new -try(14739, 9837, 9837); # old=x><x> , new=x><x ; old = new -try(14071, 10505, 7344); # old=x><x> , new=x><x ; old > new -try( 8192, 8192, 8192); # old=<x> , new=<x> ; old = new -try( 8192, 14817, 8192); # old=<x><x , new=<x> ; old > new -try( 8192, 16384, 8192); # old=<x><x> , new=<x> ; old > new -try( 8192, 24576, 8192); # old=<x><x><x>, new=<x> ; old > new -try( 8192, 9001, 9001); # old=<x><x , new=<x><x ; old = new -try( 8192, 11760, 10274); # old=<x><x , new=<x><x ; old > new -try( 8192, 16384, 10781); # old=<x><x> , new=<x><x ; old > new -try( 8192, 24576, 9284); # old=<x><x><x>, new=<x><x ; old > new -try(14761, 9815, 9815); # old=x><x> , new=x><x> ; old = new -try( 8192, 16384, 16384); # old=<x><x> , new=<x><x> ; old = new -try( 8192, 24576, 16384); # old=<x><x><x>, new=<x><x> ; old > new -try( 8192, 24576, 24576); # old=<x><x><x>, new=<x><x><x>; old = new -try( 8771, 776, 0); # old=x , new=0 ; old > new -try( 8192, 2813, 0); # old=<x , new=0 ; old > new -try(13945, 2439, 0); # old=x> , new=0 ; old > new -try(14493, 6090, 0); # old=x><x , new=0 ; old > new -try( 8192, 8192, 0); # old=<x> , new=0 ; old > new -try( 8192, 10030, 0); # old=<x><x , new=0 ; old > new -try(14983, 9593, 0); # old=x><x> , new=0 ; old > new -try( 8192, 16384, 0); # old=<x><x> , new=0 ; old > new -try( 8192, 24576, 0); # old=<x><x><x>, new=0 ; old > new -try(10489, 0, 0); # old=0 , new=0 ; old = new - -print "# SOF tests\n"; -# These tests all take place at the start of the file -try( 0, 4868, 4868); # old=<x , new=<x ; old = new -try( 0, 147, 118); # old=<x , new=<x ; old > new -try( 0, 8192, 8192); # old=<x> , new=<x ; old = new -try( 0, 8192, 4574); # old=<x> , new=<x ; old > new -try( 0, 11891, 1917); # old=<x><x , new=<x ; old > new -try( 0, 16384, 5155); # old=<x><x> , new=<x ; old > new -try( 0, 24576, 2953); # old=<x><x><x>, new=<x ; old > new -try( 0, 8192, 8192); # old=<x> , new=<x> ; old = new -try( 0, 11083, 8192); # old=<x><x , new=<x> ; old > new -try( 0, 16384, 8192); # old=<x><x> , new=<x> ; old > new -try( 0, 24576, 8192); # old=<x><x><x>, new=<x> ; old > new -try( 0, 14126, 14126); # old=<x><x , new=<x><x ; old = new -try( 0, 12002, 9034); # old=<x><x , new=<x><x ; old > new -try( 0, 16384, 13258); # old=<x><x> , new=<x><x ; old > new -try( 0, 24576, 14367); # old=<x><x><x>, new=<x><x ; old > new -try( 0, 16384, 16384); # old=<x><x> , new=<x><x> ; old = new -try( 0, 24576, 16384); # old=<x><x><x>, new=<x><x> ; old > new -try( 0, 24576, 24576); # old=<x><x><x>, new=<x><x><x>; old = new -try( 0, 6530, 0); # old=<x , new=0 ; old > new -try( 0, 8192, 0); # old=<x> , new=0 ; old > new -try( 0, 14707, 0); # old=<x><x , new=0 ; old > new -try( 0, 16384, 0); # old=<x><x> , new=0 ; old > new -try( 0, 24576, 0); # old=<x><x><x>, new=0 ; old > new -try( 0, 0, 0); # old=0 , new=0 ; old = new - -print "# EOF tests 1\n"; -# These tests all take place at the end of the file -$FLEN = 40960; # Force the file to be exactly 40960 bytes long -$oldfile = mkrand($FLEN); -try(32768, 8192, 8192); # old=<x> , new=<x ; old = new -try(32768, 8192, 4026); # old=<x> , new=<x ; old > new -try(24576, 16384, 1917); # old=<x><x> , new=<x ; old > new -try(16384, 24576, 3818); # old=<x><x><x>, new=<x ; old > new -try(32768, 8192, 8192); # old=<x> , new=<x> ; old = new -try(24576, 16384, 8192); # old=<x><x> , new=<x> ; old > new -try(16384, 24576, 8192); # old=<x><x><x>, new=<x> ; old > new -try(24576, 16384, 12221); # old=<x><x> , new=<x><x ; old > new -try(16384, 24576, 15030); # old=<x><x><x>, new=<x><x ; old > new -try(24576, 16384, 16384); # old=<x><x> , new=<x><x> ; old = new -try(16384, 24576, 16384); # old=<x><x><x>, new=<x><x> ; old > new -try(16384, 24576, 24576); # old=<x><x><x>, new=<x><x><x>; old = new -try(35973, 4987, 0); # old=x> , new=0 ; old > new -try(32768, 8192, 0); # old=<x> , new=0 ; old > new -try(29932, 11028, 0); # old=x><x> , new=0 ; old > new -try(24576, 16384, 0); # old=<x><x> , new=0 ; old > new -try(16384, 24576, 0); # old=<x><x><x>, new=0 ; old > new -try(40960, 0, 0); # old=0 , new=0 ; old = new - -print "# EOF tests 2\n"; -# These tests all take place at the end of the file -$FLEN = 42000; # Force the file to be exactly 42000 bytes long -$oldfile = mkrand($FLEN); -try(41683, 317, 317); # old=x , new=x ; old = new -try(41225, 775, 405); # old=x , new=x ; old > new -try(35709, 6291, 284); # old=x><x , new=x ; old > new -try(40960, 1040, 1040); # old=<x , new=<x ; old = new -try(40960, 1040, 378); # old=<x , new=<x ; old > new -try(32768, 9232, 5604); # old=<x><x , new=<x ; old > new -try(39994, 2006, 966); # old=x><x , new=x> ; old > new -try(36725, 5275, 5275); # old=x><x , new=x><x ; old = new -try(37990, 4010, 3199); # old=x><x , new=x><x ; old > new -try(32768, 9232, 8192); # old=<x><x , new=<x> ; old > new -try(32768, 9232, 9232); # old=<x><x , new=<x><x ; old = new -try(32768, 9232, 8795); # old=<x><x , new=<x><x ; old > new -try(41500, 500, 0); # old=x , new=0 ; old > new -try(40960, 1040, 0); # old=<x , new=0 ; old > new -try(35272, 6728, 0); # old=x><x , new=0 ; old > new -try(32768, 9232, 0); # old=<x><x , new=0 ; old > new -try(42000, 0, 0); # old=0 , new=0 ; old = new - -# Now the REAL tests -# Make sure mtwrite can properly write sequences of several intervals -# The intervals tested above were accumulated into @TRIES. -# try_all_doubles() tries every possible sensible pair of those intervals. -# try_all_triples() tries every possible sensible group of -# tree intervals from the more restrictive set @BASE_TRIES. -$FLEN = 40970; -$oldfile = mkrand($FLEN); -try_all_doubles(); -try_all_triples(); - -sub mkrand { - my $len = shift; - srand $len; - my @c = ('a' .. 'z', 'A' .. 'Z', 0..9, $:); - my $d = ""; - $d .= $c[rand @c] until length($d) >= $len; - substr($d, $len) = ""; # chop it off to the proper length - $d; -} - -sub try { - push @TRIES, [@_] if @_ == 3; - - open F, "> $file" or die "Couldn't open file $file: $!"; - binmode F; - print F $oldfile; - close F; - die "wrong length!" unless -s $file == $FLEN; - - my @mt_args; - my $expected = $oldfile; - { my @a = @_; - my $c = "a"; - while (@a) { - my ($s, $len, $newlen) = splice @a, -3; - my $newdata = $c++ x $newlen; - substr($expected, $s, $len, $newdata); - unshift @mt_args, $newdata, $s, $len; - } - } - - my $o = tie my @lines, 'Tie::File', $file or die $!; - my $actual_return = $o->_mtwrite(@mt_args); - undef $o; untie @lines; - - open F, "< $file" or die "Couldn't open file $file: $!"; - binmode F; - my $actual; - { local $/; - $actual = <F>; - } - close F; - - my ($alen, $xlen) = (length $actual, length $expected); - unless ($alen == $xlen) { - print "# try(@_) expected file length $xlen, actual $alen!\n"; - } - print $actual eq $expected ? "ok $N\n" : "not ok $N\n"; - $N++; - -# if (! defined $actual_return && ! defined $expected_return) { -# print "ok $N\n"; -# } elsif (! defined $actual_return || ! defined $expected_return) { -# print "not ok $N\n"; -# } else { -# print $actual_return eq $expected_return ? "ok $N\n" : "not ok $N\n"; -# } -# $N++; -} - -sub try_all_doubles { - print "# Trying double regions.\n"; - for my $a (@TRIES) { - next if $a->[0] + $a->[1] >= $FLEN; - next if $a->[0] + $a->[2] >= $FLEN; - for my $b (@TRIES) { - next if $b->[0] + $b->[1] >= $FLEN; - next if $b->[0] + $b->[2] >= $FLEN; - - next if $b->[0] < $a->[0] + $a->[1]; # Overlapping regions - try(@$a, @$b); - } - } -} - -sub try_all_triples { - print "# Trying triple regions.\n"; - for my $a (@BASE_TRIES) { - next if $a->[0] + $a->[1] >= $FLEN; - next if $a->[0] + $a->[2] >= $FLEN; - for my $b (@BASE_TRIES) { - next if $b->[0] + $b->[1] >= $FLEN; - next if $b->[0] + $b->[2] >= $FLEN; - - next if $b->[0] < $a->[0] + $a->[1]; # Overlapping regions - - for my $c (@BASE_TRIES) { - next if $c->[0] + $c->[1] >= $FLEN; - next if $c->[0] + $c->[2] >= $FLEN; - - next if $c->[0] < $b->[0] + $b->[1]; # Overlapping regions - try(@$a, @$b, @$c); - } - } - } -} - -sub ctrlfix { - for (@_) { - s/\n/\\n/g; - s/\r/\\r/g; - } -} - -END { - 1 while unlink $file; -} - diff --git a/lib/Tie/File/t/29_downcopy.t b/lib/Tie/File/t/29_downcopy.t deleted file mode 100644 index d75806d5b2..0000000000 --- a/lib/Tie/File/t/29_downcopy.t +++ /dev/null @@ -1,363 +0,0 @@ -#!/usr/bin/perl -# -# Unit tests of _downcopy function -# -# _downcopy($self, $data, $pos, $len) -# Write $data into a block of length $len at position $pos, -# moving everything in the block forwards to make room. -# Instead of writing the last length($data) bytes from the block -# (because there isn't room for them any longer) return them. -# -# - -my $file = "tf$$.txt"; - -print "1..718\n"; - -my $N = 1; -use Tie::File; -print "ok $N\n"; $N++; - -$: = Tie::File::_default_recsep(); - -my @subtests = qw(x <x x> x><x <x> <x><x x><x> <x><x> <x><x><x> 0); -print "ok $N\n"; $N++; - -# (3-144) These were generated by 'gentests.pl' to cover all possible cases -# (I hope) -# Legend: -# x: data is entirely contained within one block -# x>: data runs from the middle to the end of the block -# <x: data runs from the start to the middle of the block -# <x>: data occupies precisely one block -# x><x: data overlaps one block boundary -# <x><x: data runs from the start of one block into the middle of the next -# x><x>: data runs from the middle of one block to the end of the next -# <x><x>: data occupies two blocks exactly -# <x><x><x>: data occupies three blocks exactly -# 0: data is null -# -# For each possible alignment of the old and new data, we investigate -# up to three situations: old data is shorter, old and new data are the -# same length, and new data is shorter. -# -# try($pos, $old, $new) means to run a test where the data starts at -# position $pos, the old data has length $old, -# and the new data has length $new. -try( 9659, 6635, 6691); # old=x , new=x ; old < new -try( 8605, 2394, 2394); # old=x , new=x ; old = new -try( 9768, 1361, 664); # old=x , new=x ; old > new -try( 9955, 6429, 6429); # old=x> , new=x ; old = new -try(10550, 5834, 4123); # old=x> , new=x ; old > new -try(14580, 6158, 851); # old=x><x , new=x ; old > new -try(13442, 11134, 1572); # old=x><x> , new=x ; old > new -try( 8394, 0, 5742); # old=0 , new=x ; old < new -try( 8192, 2819, 6738); # old=<x , new=<x ; old < new -try( 8192, 514, 514); # old=<x , new=<x ; old = new -try( 8192, 2196, 858); # old=<x , new=<x ; old > new -try( 8192, 8192, 8192); # old=<x> , new=<x ; old = new -try( 8192, 8192, 1290); # old=<x> , new=<x ; old > new -try( 8192, 10575, 6644); # old=<x><x , new=<x ; old > new -try( 8192, 16384, 5616); # old=<x><x> , new=<x ; old > new -try( 8192, 24576, 6253); # old=<x><x><x>, new=<x ; old > new -try( 8192, 0, 6870); # old=0 , new=<x ; old < new -try( 8478, 6259, 7906); # old=x , new=x> ; old < new -try( 9965, 6419, 6419); # old=x> , new=x> ; old = new -try(16059, 6102, 325); # old=x><x , new=x> ; old > new -try( 9503, 15073, 6881); # old=x><x> , new=x> ; old > new -try( 9759, 0, 6625); # old=0 , new=x> ; old < new -try( 8525, 2081, 8534); # old=x , new=x><x ; old < new -try(15550, 834, 1428); # old=x> , new=x><x ; old < new -try(14966, 1668, 3479); # old=x><x , new=x><x ; old < new -try(16316, 1605, 1605); # old=x><x , new=x><x ; old = new -try(16093, 4074, 993); # old=x><x , new=x><x ; old > new -try(14739, 9837, 9837); # old=x><x> , new=x><x ; old = new -try(14071, 10505, 7344); # old=x><x> , new=x><x ; old > new -try(12602, 0, 8354); # old=0 , new=x><x ; old < new -try( 8192, 2767, 8192); # old=<x , new=<x> ; old < new -try( 8192, 8192, 8192); # old=<x> , new=<x> ; old = new -try( 8192, 14817, 8192); # old=<x><x , new=<x> ; old > new -try( 8192, 16384, 8192); # old=<x><x> , new=<x> ; old > new -try( 8192, 24576, 8192); # old=<x><x><x>, new=<x> ; old > new -try( 8192, 0, 8192); # old=0 , new=<x> ; old < new -try( 8192, 6532, 10882); # old=<x , new=<x><x ; old < new -try( 8192, 8192, 16044); # old=<x> , new=<x><x ; old < new -try( 8192, 9555, 11020); # old=<x><x , new=<x><x ; old < new -try( 8192, 9001, 9001); # old=<x><x , new=<x><x ; old = new -try( 8192, 11760, 10274); # old=<x><x , new=<x><x ; old > new -try( 8192, 16384, 10781); # old=<x><x> , new=<x><x ; old > new -try( 8192, 24576, 9284); # old=<x><x><x>, new=<x><x ; old > new -try( 8192, 0, 12488); # old=0 , new=<x><x ; old < new -try( 8222, 6385, 16354); # old=x , new=x><x> ; old < new -try(13500, 2884, 11076); # old=x> , new=x><x> ; old < new -try(14069, 4334, 10507); # old=x><x , new=x><x> ; old < new -try(14761, 9815, 9815); # old=x><x> , new=x><x> ; old = new -try(10469, 0, 14107); # old=0 , new=x><x> ; old < new -try( 8192, 4181, 16384); # old=<x , new=<x><x> ; old < new -try( 8192, 8192, 16384); # old=<x> , new=<x><x> ; old < new -try( 8192, 12087, 16384); # old=<x><x , new=<x><x> ; old < new -try( 8192, 16384, 16384); # old=<x><x> , new=<x><x> ; old = new -try( 8192, 24576, 16384); # old=<x><x><x>, new=<x><x> ; old > new -try( 8192, 0, 16384); # old=0 , new=<x><x> ; old < new -try( 8192, 4968, 24576); # old=<x , new=<x><x><x>; old < new -try( 8192, 8192, 24576); # old=<x> , new=<x><x><x>; old < new -try( 8192, 14163, 24576); # old=<x><x , new=<x><x><x>; old < new -try( 8192, 16384, 24576); # old=<x><x> , new=<x><x><x>; old < new -try( 8192, 24576, 24576); # old=<x><x><x>, new=<x><x><x>; old = new -try( 8192, 0, 24576); # old=0 , new=<x><x><x>; old < new -try( 8771, 776, 0); # old=x , new=0 ; old > new -try( 8192, 2813, 0); # old=<x , new=0 ; old > new -try(13945, 2439, 0); # old=x> , new=0 ; old > new -try(14493, 6090, 0); # old=x><x , new=0 ; old > new -try( 8192, 8192, 0); # old=<x> , new=0 ; old > new -try( 8192, 10030, 0); # old=<x><x , new=0 ; old > new -try(14983, 9593, 0); # old=x><x> , new=0 ; old > new -try( 8192, 16384, 0); # old=<x><x> , new=0 ; old > new -try( 8192, 24576, 0); # old=<x><x><x>, new=0 ; old > new -try(10489, 0, 0); # old=0 , new=0 ; old = new - -# (142-223) -# These tests all take place at the start of the file -try( 0, 771, 1593); # old=<x , new=<x ; old < new -try( 0, 4868, 4868); # old=<x , new=<x ; old = new -try( 0, 147, 118); # old=<x , new=<x ; old > new -try( 0, 8192, 8192); # old=<x> , new=<x ; old = new -try( 0, 8192, 4574); # old=<x> , new=<x ; old > new -try( 0, 11891, 1917); # old=<x><x , new=<x ; old > new -try( 0, 16384, 5155); # old=<x><x> , new=<x ; old > new -try( 0, 24576, 2953); # old=<x><x><x>, new=<x ; old > new -try( 0, 0, 1317); # old=0 , new=<x ; old < new -try( 0, 5609, 8192); # old=<x , new=<x> ; old < new -try( 0, 8192, 8192); # old=<x> , new=<x> ; old = new -try( 0, 11083, 8192); # old=<x><x , new=<x> ; old > new -try( 0, 16384, 8192); # old=<x><x> , new=<x> ; old > new -try( 0, 24576, 8192); # old=<x><x><x>, new=<x> ; old > new -try( 0, 0, 8192); # old=0 , new=<x> ; old < new -try( 0, 6265, 9991); # old=<x , new=<x><x ; old < new -try( 0, 8192, 16119); # old=<x> , new=<x><x ; old < new -try( 0, 10218, 11888); # old=<x><x , new=<x><x ; old < new -try( 0, 14126, 14126); # old=<x><x , new=<x><x ; old = new -try( 0, 12002, 9034); # old=<x><x , new=<x><x ; old > new -try( 0, 16384, 13258); # old=<x><x> , new=<x><x ; old > new -try( 0, 24576, 14367); # old=<x><x><x>, new=<x><x ; old > new -try( 0, 0, 10881); # old=0 , new=<x><x ; old < new -try( 0, 6448, 16384); # old=<x , new=<x><x> ; old < new -try( 0, 8192, 16384); # old=<x> , new=<x><x> ; old < new -try( 0, 15082, 16384); # old=<x><x , new=<x><x> ; old < new -try( 0, 16384, 16384); # old=<x><x> , new=<x><x> ; old = new -try( 0, 24576, 16384); # old=<x><x><x>, new=<x><x> ; old > new -try( 0, 0, 16384); # old=0 , new=<x><x> ; old < new -try( 0, 2421, 24576); # old=<x , new=<x><x><x>; old < new -try( 0, 8192, 24576); # old=<x> , new=<x><x><x>; old < new -try( 0, 11655, 24576); # old=<x><x , new=<x><x><x>; old < new -try( 0, 16384, 24576); # old=<x><x> , new=<x><x><x>; old < new -try( 0, 24576, 24576); # old=<x><x><x>, new=<x><x><x>; old = new -try( 0, 0, 24576); # old=0 , new=<x><x><x>; old < new -try( 0, 6530, 0); # old=<x , new=0 ; old > new -try( 0, 8192, 0); # old=<x> , new=0 ; old > new -try( 0, 14707, 0); # old=<x><x , new=0 ; old > new -try( 0, 16384, 0); # old=<x><x> , new=0 ; old > new -try( 0, 24576, 0); # old=<x><x><x>, new=0 ; old > new -try( 0, 0, 0); # old=0 , new=0 ; old = new - -# (224-277) -# These tests all take place at the end of the file -$FLEN = 40960; # Force the file to be exactly 40960 bytes long -try(32768, 8192, 8192); # old=<x> , new=<x ; old = new -try(32768, 8192, 4026); # old=<x> , new=<x ; old > new -try(24576, 16384, 1917); # old=<x><x> , new=<x ; old > new -try(16384, 24576, 3818); # old=<x><x><x>, new=<x ; old > new -try(40960, 0, 2779); # old=0 , new=<x ; old < new -try(32768, 8192, 8192); # old=<x> , new=<x> ; old = new -try(24576, 16384, 8192); # old=<x><x> , new=<x> ; old > new -try(16384, 24576, 8192); # old=<x><x><x>, new=<x> ; old > new -try(40960, 0, 8192); # old=0 , new=<x> ; old < new -try(32768, 8192, 10724); # old=<x> , new=<x><x ; old < new -try(24576, 16384, 12221); # old=<x><x> , new=<x><x ; old > new -try(16384, 24576, 15030); # old=<x><x><x>, new=<x><x ; old > new -try(40960, 0, 11752); # old=0 , new=<x><x ; old < new -try(32768, 8192, 16384); # old=<x> , new=<x><x> ; old < new -try(24576, 16384, 16384); # old=<x><x> , new=<x><x> ; old = new -try(16384, 24576, 16384); # old=<x><x><x>, new=<x><x> ; old > new -try(40960, 0, 16384); # old=0 , new=<x><x> ; old < new -try(32768, 8192, 24576); # old=<x> , new=<x><x><x>; old < new -try(24576, 16384, 24576); # old=<x><x> , new=<x><x><x>; old < new -try(16384, 24576, 24576); # old=<x><x><x>, new=<x><x><x>; old = new -try(40960, 0, 24576); # old=0 , new=<x><x><x>; old < new -try(35973, 4987, 0); # old=x> , new=0 ; old > new -try(32768, 8192, 0); # old=<x> , new=0 ; old > new -try(29932, 11028, 0); # old=x><x> , new=0 ; old > new -try(24576, 16384, 0); # old=<x><x> , new=0 ; old > new -try(16384, 24576, 0); # old=<x><x><x>, new=0 ; old > new -try(40960, 0, 0); # old=0 , new=0 ; old = new - -# (278-357) -# These tests all take place at the end of the file -$FLEN = 42000; # Force the file to be exactly 42000 bytes long -try(41275, 725, 4059); # old=x , new=x ; old < new -try(41683, 317, 317); # old=x , new=x ; old = new -try(41225, 775, 405); # old=x , new=x ; old > new -try(35709, 6291, 284); # old=x><x , new=x ; old > new -try(42000, 0, 2434); # old=0 , new=x ; old < new -try(40960, 1040, 1608); # old=<x , new=<x ; old < new -try(40960, 1040, 1040); # old=<x , new=<x ; old = new -try(40960, 1040, 378); # old=<x , new=<x ; old > new -try(32768, 9232, 5604); # old=<x><x , new=<x ; old > new -try(42000, 0, 6637); # old=0 , new=<x ; old < new -try(41022, 978, 8130); # old=x , new=x> ; old < new -try(39994, 2006, 966); # old=x><x , new=x> ; old > new -try(42000, 0, 7152); # old=0 , new=x> ; old < new -try(41613, 387, 10601); # old=x , new=x><x ; old < new -try(38460, 3540, 3938); # old=x><x , new=x><x ; old < new -try(36725, 5275, 5275); # old=x><x , new=x><x ; old = new -try(37990, 4010, 3199); # old=x><x , new=x><x ; old > new -try(42000, 0, 9189); # old=0 , new=x><x ; old < new -try(40960, 1040, 8192); # old=<x , new=<x> ; old < new -try(32768, 9232, 8192); # old=<x><x , new=<x> ; old > new -try(42000, 0, 8192); # old=0 , new=<x> ; old < new -try(40960, 1040, 11778); # old=<x , new=<x><x ; old < new -try(32768, 9232, 13792); # old=<x><x , new=<x><x ; old < new -try(32768, 9232, 9232); # old=<x><x , new=<x><x ; old = new -try(32768, 9232, 8795); # old=<x><x , new=<x><x ; old > new -try(42000, 0, 8578); # old=0 , new=<x><x ; old < new -try(41531, 469, 15813); # old=x , new=x><x> ; old < new -try(39618, 2382, 9534); # old=x><x , new=x><x> ; old < new -try(42000, 0, 15344); # old=0 , new=x><x> ; old < new -try(40960, 1040, 16384); # old=<x , new=<x><x> ; old < new -try(32768, 9232, 16384); # old=<x><x , new=<x><x> ; old < new -try(42000, 0, 16384); # old=0 , new=<x><x> ; old < new -try(40960, 1040, 24576); # old=<x , new=<x><x><x>; old < new -try(32768, 9232, 24576); # old=<x><x , new=<x><x><x>; old < new -try(42000, 0, 24576); # old=0 , new=<x><x><x>; old < new -try(41500, 500, 0); # old=x , new=0 ; old > new -try(40960, 1040, 0); # old=<x , new=0 ; old > new -try(35272, 6728, 0); # old=x><x , new=0 ; old > new -try(32768, 9232, 0); # old=<x><x , new=0 ; old > new -try(42000, 0, 0); # old=0 , new=0 ; old = new - -sub try { - my ($pos, $len, $newlen) = @_; - open F, "> $file" or die "Couldn't open file $file: $!"; - binmode F; - - # The record has exactly 17 characters. This will help ensure that - # even if _downcoopy screws up, the data doesn't coincidentally - # look good because the remainder accidentally lines up. - my $d = substr("0123456789abcdef$:", -17); - my $recs = defined($FLEN) ? - int($FLEN/length($d))+1 : # enough to make up at least $FLEN - int(8192*5/length($d))+1; # at least 5 blocks' worth - my $oldfile = $d x $recs; - my $flen = defined($FLEN) ? $FLEN : $recs * 17; - substr($oldfile, $FLEN) = "" if defined $FLEN; # truncate - print F $oldfile; - close F; - - die "wrong length!" unless -s $file == $flen; - - my $newdata = "-" x $newlen; - my $expected = $oldfile; - my $old = defined $len ? substr($expected, $pos, $len) - : substr($expected, $pos); - $old = "$newdata$old"; - my $x_retval; - if (defined $len) { - substr($expected, $pos, $len, substr($old, 0, $len, "")); - $x_retval = $old; - } else { - substr($expected, $pos) = $old; - $x_retval = ""; - } - - my $o = tie my @lines, 'Tie::File', $file or die $!; - local $SIG{ALRM} = sub { die "Alarm clock" }; - my $a_retval = eval { alarm(5) unless $^P; $o->_downcopy($newdata, $pos, $len) }; - my $err = $@; - undef $o; untie @lines; alarm(0); - if ($err) { - if ($err =~ /^Alarm clock/) { - print "# Timeout\n"; - print "not ok $N\n"; $N++; - print "not ok $N\n"; $N++; - return; - } else { - $@ = $err; - die; - } - } - - open F, "< $file" or die "Couldn't open file $file: $!"; - binmode F; - my $actual; - { local $/; - $actual = <F>; - } - close F; - - my ($alen, $xlen) = (length $actual, length $expected); - unless ($alen == $xlen) { - my @ARGS = @_; - for (@ARGS) { $_ = "UNDEF" unless defined } - print "# try(@ARGS) expected file length $xlen, actual $alen!\n"; - } - print $actual eq $expected ? "ok $N\n" : "not ok $N\n"; - $N++; - print $a_retval eq $x_retval ? "ok $N\n" : "not ok $N\n"; - $N++; - - if (defined $len) { - try($pos, undef, $newlen); - } -} - - - -use POSIX 'SEEK_SET'; -sub check_contents { - my @c = @_; - my $x = join $:, @c, ''; - local *FH = $o->{fh}; - seek FH, 0, SEEK_SET; -# my $open = open FH, "< $file"; - my $a; - { local $/; $a = <FH> } - $a = "" unless defined $a; - if ($a eq $x) { - print "ok $N\n"; - } else { - ctrlfix($a, $x); - print "not ok $N\n# expected <$x>, got <$a>\n"; - } - $N++; - - # now check FETCH: - my $good = 1; - my $msg; - for (0.. $#c) { - my $aa = $a[$_]; - unless ($aa eq "$c[$_]$:") { - $msg = "expected <$c[$_]$:>, got <$aa>"; - ctrlfix($msg); - $good = 0; - } - } - print $good ? "ok $N\n" : "not ok $N # $msg\n"; - $N++; - - print $o->_check_integrity($file, $ENV{INTEGRITY}) - ? "ok $N\n" : "not ok $N\n"; - $N++; -} - -sub ctrlfix { - for (@_) { - s/\n/\\n/g; - s/\r/\\r/g; - } -} - -END { - undef $o; - untie @a; - 1 while unlink $file; -} diff --git a/lib/Tie/File/t/29a_upcopy.t b/lib/Tie/File/t/29a_upcopy.t deleted file mode 100644 index 1130615f37..0000000000 --- a/lib/Tie/File/t/29a_upcopy.t +++ /dev/null @@ -1,211 +0,0 @@ -#!/usr/bin/perl -# -# Unit tests of _upcopy function -# -# _upcopy($self, $source, $dest, $len) -# -# Take a block of data of leength $len at $source and copy it -# to $dest, which must be <= $source but which need not be <= $source - $len -# (That is, this will only copy a block to a position earlier in the file, -# but the source and destination regions may overlap.) - - -my $file = "tf$$.txt"; - -print "1..55\n"; - -my $N = 1; -use Tie::File; -print "ok $N\n"; $N++; - -$: = Tie::File::_default_recsep(); - -my @subtests = qw(x <x x> x><x <x> <x><x x><x> <x><x> <x><x><x> 0); - -$FLEN = 40970; # 2410 records of 17 chars each - -# (2-7) Trivial non-moves at start of file -try(0, 0, 0); -try(0, 0, 10); -try(0, 0, 100); -try(0, 0, 1000); -try(0, 0, 10000); -try(0, 0, 20000); - -# (8-13) Trivial non-moves in middle of file -try(100, 100, 0); -try(100, 100, 10); -try(100, 100, 100); -try(100, 100, 1000); -try(100, 100, 10000); -try(100, 100, 20000); - -# (14) Trivial non-move at end of file -try($FLEN, $FLEN, 0); - -# (15-17) Trivial non-move of tail of file -try(0, 0, undef); -try(100, 100, undef); -try($FLEN, $FLEN, undef); - -# (18-24) Moves to start of file -try(100, 0, 0); -try(100, 0, 10); -try(100, 0, 100); -try(100, 0, 1000); -try(100, 0, 10000); -try(100, 0, 20000); -try(100, 0, undef); - -# (25-31) Moves in middle of file -try(200, 100, 0); -try(200, 100, 10); -try(200, 100, 100); -try(200, 100, 1000); -try(200, 100, 10000); -try(200, 100, 20000); -try(200, 100, undef); - -# (32-43) Moves from end of file -try($FLEN, 10000, 0); -try($FLEN-10, 10000, 10); -try($FLEN-100, 10000, 100); -try($FLEN-1000, 200, 1000); -try($FLEN-10000, 200, 10000); -try($FLEN-20000, 200, 20000); -try($FLEN, 10000, undef); -try($FLEN-10, 10000, undef); -try($FLEN-100, 10000, undef); -try($FLEN-1000, 200, undef); -try($FLEN-10000, 200, undef); -try($FLEN-20000, 200, undef); - -$FLEN = 40960; - -# (44-55) Moves from end of file when file ends on a block boundary -try($FLEN, 10000, 0); -try($FLEN-10, 10000, 10); -try($FLEN-100, 10000, 100); -try($FLEN-1000, 200, 1000); -try($FLEN-10000, 200, 10000); -try($FLEN-20000, 200, 20000); -try($FLEN, 10000, undef); -try($FLEN-10, 10000, undef); -try($FLEN-100, 10000, undef); -try($FLEN-1000, 200, undef); -try($FLEN-10000, 200, undef); -try($FLEN-20000, 200, undef); - -sub try { - my ($src, $dst, $len) = @_; - open F, "> $file" or die "Couldn't open file $file: $!"; - binmode F; - - # The record has exactly 17 characters. This will help ensure that - # even if _upcopy screws up, the data doesn't coincidentally - # look good because the remainder accidentally lines up. - my $d = substr("0123456789abcdef$:", -17); - my $recs = defined($FLEN) ? - int($FLEN/length($d))+1 : # enough to make up at least $FLEN - int(8192*5/length($d))+1; # at least 5 blocks' worth - my $oldfile = $d x $recs; - my $flen = defined($FLEN) ? $FLEN : $recs * 17; - substr($oldfile, $FLEN) = "" if defined $FLEN; # truncate - print F $oldfile; - close F; - - die "wrong length!" unless -s $file == $flen; - - # If len is specified, use that. If it's undef, - # then behave *as if* we had specified the whole rest of the file - my $expected = $oldfile; - if (defined $len) { - substr($expected, $dst, $len) = substr($expected, $src, $len); - } else { - substr($expected, $dst) = substr($expected, $src); - } - - my $o = tie my @lines, 'Tie::File', $file or die $!; - local $SIG{ALRM} = sub { die "Alarm clock" }; - my $a_retval = eval { alarm(5) unless $^P; $o->_upcopy($src, $dst, $len) }; - my $err = $@; - undef $o; untie @lines; alarm(0); - if ($err) { - if ($err =~ /^Alarm clock/) { - print "# Timeout\n"; - print "not ok $N\n"; $N++; - return; - } else { - $@ = $err; - die; - } - } - - open F, "< $file" or die "Couldn't open file $file: $!"; - binmode F; - my $actual; - { local $/; - $actual = <F>; - } - close F; - - my ($alen, $xlen) = (length $actual, length $expected); - unless ($alen == $xlen) { - print "# try(@_) expected file length $xlen, actual $alen!\n"; - } - print $actual eq $expected ? "ok $N\n" : "not ok $N\n"; - $N++; -} - - - -use POSIX 'SEEK_SET'; -sub check_contents { - my @c = @_; - my $x = join $:, @c, ''; - local *FH = $o->{fh}; - seek FH, 0, SEEK_SET; -# my $open = open FH, "< $file"; - my $a; - { local $/; $a = <FH> } - $a = "" unless defined $a; - if ($a eq $x) { - print "ok $N\n"; - } else { - ctrlfix($a, $x); - print "not ok $N\n# expected <$x>, got <$a>\n"; - } - $N++; - - # now check FETCH: - my $good = 1; - my $msg; - for (0.. $#c) { - my $aa = $a[$_]; - unless ($aa eq "$c[$_]$:") { - $msg = "expected <$c[$_]$:>, got <$aa>"; - ctrlfix($msg); - $good = 0; - } - } - print $good ? "ok $N\n" : "not ok $N # $msg\n"; - $N++; - - print $o->_check_integrity($file, $ENV{INTEGRITY}) - ? "ok $N\n" : "not ok $N\n"; - $N++; -} - -sub ctrlfix { - for (@_) { - s/\n/\\n/g; - s/\r/\\r/g; - } -} - -END { - undef $o; - untie @a; - 1 while unlink $file; -} - diff --git a/lib/Tie/File/t/30_defer.t b/lib/Tie/File/t/30_defer.t deleted file mode 100644 index 063b3a7090..0000000000 --- a/lib/Tie/File/t/30_defer.t +++ /dev/null @@ -1,328 +0,0 @@ -#!/usr/bin/perl -# -# Check ->defer and ->flush methods -# -# This is the old version, which you used in the past when -# there was a defer buffer separate from the read cache. -# There isn't any longer. -# - -use POSIX 'SEEK_SET'; -my $file = "tf$$.txt"; -$: = Tie::File::_default_recsep(); -my $data = "rec0$:rec1$:rec2$:"; -my ($o, $n); - -print "1..79\n"; - -my $N = 1; -use Tie::File; -print "ok $N\n"; $N++; - -open F, "> $file" or die $!; -binmode F; -print F $data; -close F; -$o = tie @a, 'Tie::File', $file; -print $o ? "ok $N\n" : "not ok $N\n"; -$N++; - -# (3-6) Deferred storage -$o->defer; -$a[3] = "rec3"; -check_contents($data); # nothing written yet -$a[4] = "rec4"; -check_contents($data); # nothing written yet - -# (7-8) Flush -$o->flush; -check_contents($data . "rec3$:rec4$:"); # now it's written - -# (9-12) Deferred writing disabled? -$a[3] = "rec9"; -check_contents("${data}rec9$:rec4$:"); -$a[4] = "rec8"; -check_contents("${data}rec9$:rec8$:"); - -# (13-18) Now let's try two batches of records -$#a = 2; -$o->defer; -$a[0] = "record0"; -check_contents($data); # nothing written yet -$a[2] = "record2"; -check_contents($data); # nothing written yet -$o->flush; -check_contents("record0$:rec1$:record2$:"); - -# (19-22) Deferred writing past the end of the file -$o->defer; -$a[4] = "record4"; -check_contents("record0$:rec1$:record2$:"); -$o->flush; -check_contents("record0$:rec1$:record2$:$:record4$:"); - - -# (23-26) Now two long batches -$o->defer; -for (0..2, 4..6) { - $a[$_] = "r$_"; -} -check_contents("record0$:rec1$:record2$:$:record4$:"); -$o->flush; -check_contents(join $:, "r0".."r2", "", "r4".."r6", ""); - -# (27-30) Now let's make sure that discarded writes are really discarded -# We have a 2Mib buffer here, so we can be sure that we aren't accidentally -# filling it up -$o->defer; -for (0, 3, 7) { - $a[$_] = "discarded$_"; -} -check_contents(join $:, "r0".."r2", "", "r4".."r6", ""); -$o->discard; -check_contents(join $:, "r0".."r2", "", "r4".."r6", ""); - -################################################################ -# -# Now we're going to test the results of a small memory limit -# -# -undef $o; untie @a; -$data = join "$:", map("record$_", 0..7), ""; # records are 8 or 9 bytes long -open F, "> $file" or die $!; -binmode F; -print F $data; -close F; - -# Limit cache+buffer size to 47 bytes -my $MAX = 47; -# -- that's enough space for 5 records, but not 6, on both \n and \r\n systems -my $BUF = 20; -# -- that's enough space for 2 records, but not 3, on both \n and \r\n systems -$o = tie @a, 'Tie::File', $file, memory => $MAX, dw_size => $BUF; -print $o ? "ok $N\n" : "not ok $N\n"; -$N++; - -# (31-32) Fill up the read cache -my @z; -@z = @a; -# the cache now contains records 3,4,5,6,7. -check_caches({map(($_ => "record$_$:"), 3..7)}, - {}); - -# (33-44) See if overloading the defer starts by flushing the read cache -# and then flushes out the defer -$o->defer; -$a[0] = "recordA"; # That should flush record 3 from the cache -check_caches({map(($_ => "record$_$:"), 4..7)}, - {0 => "recordA$:"}); -check_contents($data); - -$a[1] = "recordB"; # That should flush record 4 from the cache -check_caches({map(($_ => "record$_$:"), 5..7)}, - {0 => "recordA$:", - 1 => "recordB$:"}); -check_contents($data); - -$a[2] = "recordC"; # That should flush the whole darn defer -# This shouldn't change the cache contents -check_caches({map(($_ => "record$_$:"), 5..7)}, - {}); # URRRP -check_contents(join("$:", qw(recordA recordB recordC - record3 record4 record5 record6 record7)) . "$:"); - -$a[3] = "recordD"; # even though we flushed, deferring is STILL ENABLED -check_caches({map(($_ => "record$_$:"), 5..7)}, - {3 => "recordD$:"}); -check_contents(join("$:", qw(recordA recordB recordC - record3 record4 record5 record6 record7)) . "$:"); - -# Check readcache-deferbuffer interactions - -# (45-47) This should remove outdated data from the read cache -$a[5] = "recordE"; -check_caches({6 => "record6$:", 7 => "record7$:"}, - {3 => "recordD$:", 5 => "recordE$:"}); -check_contents(join("$:", qw(recordA recordB recordC - record3 record4 record5 record6 record7)) . "$:"); - -# (48-51) This should read back out of the defer buffer -# without adding anything to the read cache -my $z; -$z = $a[5]; -print $z eq "recordE" ? "ok $N\n" : "not ok $N\n"; $N++; -check_caches({6 => "record6$:", 7 => "record7$:"}, - {3 => "recordD$:", 5 => "recordE$:"}); -check_contents(join("$:", qw(recordA recordB recordC - record3 record4 record5 record6 record7)) . "$:"); - -# (52-55) This should repopulate the read cache with a new record -$z = $a[0]; -print $z eq "recordA" ? "ok $N\n" : "not ok $N\n"; $N++; -check_caches({0 => "recordA$:", 6 => "record6$:", 7 => "record7$:"}, - {3 => "recordD$:", 5 => "recordE$:"}); -check_contents(join("$:", qw(recordA recordB recordC - record3 record4 record5 record6 record7)) . "$:"); - -# (56-59) This should flush the LRU record from the read cache -$z = $a[4]; -print $z eq "record4" ? "ok $N\n" : "not ok $N\n"; $N++; -check_caches({7 => "record7$:", 0 => "recordA$:", 4 => "record4$:"}, - {3 => "recordD$:", 5 => "recordE$:"}); -check_contents(join("$:", qw(recordA recordB recordC - record3 record4 record5 record6 record7)) . "$:"); - -# (60-63) This should FLUSH the deferred buffer -$z = splice @a, 3, 1, "recordZ"; -print $z eq "recordD" ? "ok $N\n" : "not ok $N\n"; $N++; -check_caches({7 => "record7$:", 0 => "recordA$:", 4 => "record4$:", 3 => "recordZ$:"}, - {}); -check_contents(join("$:", qw(recordA recordB recordC - recordZ record4 recordE record6 record7)) . "$:"); - -# (64-66) We should STILL be in deferred writing mode -$a[5] = "recordX"; -check_caches({7 => "record7$:", 0 => "recordA$:", 4 => "record4$:", 3 => "recordZ$:"}, - {5 => "recordX$:"}); -check_contents(join("$:", qw(recordA recordB recordC - recordZ record4 recordE record6 record7)) . "$:"); - -# Fill up the defer buffer again -$a[4] = "recordP"; -# (67-69) This should OVERWRITE the existing deferred record -# and NOT flush the buffer -$a[5] = "recordQ"; -check_caches({7 => "record7$:", 0 => "recordA$:", 3 => "recordZ$:"}, - {5 => "recordQ$:", 4 => "recordP$:"}); -check_contents(join("$:", qw(recordA recordB recordC - recordZ record4 recordE record6 record7)) . "$:"); - -# (70-72) Discard should just dump the whole deferbuffer -$o->discard; -check_caches({7 => "record7$:", 0 => "recordA$:", 3 => "recordZ$:"}, - {}); -check_contents(join("$:", qw(recordA recordB recordC - recordZ record4 recordE record6 record7)) . "$:"); - -# (73-75) NOW we are out of deferred writing mode -$a[0] = "recordF"; -check_caches({7 => "record7$:", 0 => "recordF$:", 3 => "recordZ$:"}, - {}); -check_contents(join("$:", qw(recordF recordB recordC - recordZ record4 recordE record6 record7)) . "$:"); - -# (76-79) Last call--untying the array should flush the deferbuffer -$o->defer; -$a[0] = "flushed"; -check_caches({7 => "record7$:", 3 => "recordZ$:"}, - {0 => "flushed$:" }); -check_contents(join("$:", qw(recordF recordB recordC - recordZ record4 recordE record6 record7)) . "$:"); -undef $o; -untie @a; -# (79) We can't use check_contents any more, because the object is dead -open F, "< $file" or die; -binmode F; -{ local $/ ; $z = <F> } -close F; -my $x = join("$:", qw(flushed recordB recordC - recordZ record4 recordE record6 record7)) . "$:"; -if ($z eq $x) { - print "ok $N\n"; -} else { - my $msg = ctrlfix("expected <$x>, got <$z>"); - print "not ok $N \# $msg\n"; -} -$N++; - -################################################################ - - -sub check_caches { - my ($xcache, $xdefer) = @_; - -# my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY}); -# print $integrity ? "ok $N\n" : "not ok $N\n"; -# $N++; - - my $good = 1; - - # Copy the contents of the cache into a regular hash - my %cache; - for my $k ($o->{cache}->ckeys) { - $cache{$k} = $o->{cache}->_produce($k); - } - - $good &&= hash_equal(\%cache, $xcache, "true cache", "expected cache"); - $good &&= hash_equal($o->{deferred}, $xdefer, "true defer", "expected defer"); - print $good ? "ok $N\n" : "not ok $N\n"; - $N++; -} - -sub hash_equal { - my ($a, $b, $ha, $hb) = @_; - $ha = 'first hash' unless defined $ha; - $hb = 'second hash' unless defined $hb; - - my $good = 1; - my %b_seen; - - for my $k (keys %$a) { - if (! exists $b->{$k}) { - print ctrlfix("# Key $k is in $ha but not $hb"), "\n"; - $good = 0; - } elsif ($b->{$k} ne $a->{$k}) { - print ctrlfix("# Key $k is <$a->{$k}> in $ha but <$b->{$k}> in $hb"), "\n"; - $b_seen{$k} = 1; - $good = 0; - } else { - $b_seen{$k} = 1; - } - } - - for my $k (keys %$b) { - unless ($b_seen{$k}) { - print ctrlfix("# Key $k is in $hb but not $ha"), "\n"; - $good = 0; - } - } - - $good; -} - - -sub check_contents { - my $x = shift; - - my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY}); - print $integrity ? "ok $N\n" : "not ok $N\n"; - $N++; - - local *FH = $o->{fh}; - seek FH, 0, SEEK_SET; - - my $a; - { local $/; $a = <FH> } - $a = "" unless defined $a; - if ($a eq $x) { - print "ok $N\n"; - } else { - my $msg = ctrlfix("# expected <$x>, got <$a>"); - print "not ok $N\n$msg\n"; - } - $N++; -} - -sub ctrlfix { - local $_ = shift; - s/\n/\\n/g; - s/\r/\\r/g; - $_; -} - -END { - undef $o; - untie @a if tied @a; - 1 while unlink $file; -} - diff --git a/lib/Tie/File/t/31_autodefer.t b/lib/Tie/File/t/31_autodefer.t deleted file mode 100644 index ea929a4097..0000000000 --- a/lib/Tie/File/t/31_autodefer.t +++ /dev/null @@ -1,182 +0,0 @@ -#!/usr/bin/perl -# -# Check behavior of 'autodefer' feature -# Mostly this isn't implemented yet -# This file is primarily here to make sure that the promised ->autodefer -# method doesn't croak. -# - -use POSIX 'SEEK_SET'; - -my $file = "tf$$.txt"; -$: = Tie::File::_default_recsep(); -my $data = "rec0$:rec1$:rec2$:"; -my ($o, $n, @a); - -print "1..65\n"; - -my $N = 1; -use Tie::File; -print "ok $N\n"; $N++; - -open F, "> $file" or die $!; -binmode F; -print F $data; -close F; -$o = tie @a, 'Tie::File', $file; -print $o ? "ok $N\n" : "not ok $N\n"; -$N++; - -# I am an undocumented feature -$o->{autodefer_filelen_threshhold} = 0; -# Normally autodeferring only works on large files. This disables that. - -# (3-22) Deferred storage -$a[3] = "rec3"; -check_autodeferring('OFF'); -$a[4] = "rec4"; -check_autodeferring('OFF'); -$a[5] = "rec5"; -check_autodeferring('ON'); -check_contents($data . "rec3$:rec4$:"); # only the first two were written -$a[6] = "rec6"; -check_autodeferring('ON'); -check_contents($data . "rec3$:rec4$:"); # still nothing written -$a[7] = "rec7"; -check_autodeferring('ON'); -check_contents($data . "rec3$:rec4$:"); # still nothing written -$a[0] = "recX"; -check_autodeferring('OFF'); -check_contents("recX$:rec1$:rec2$:rec3$:rec4$:rec5$:rec6$:rec7$:"); -$a[1] = "recY"; -check_autodeferring('OFF'); -check_contents("recX$:recY$:rec2$:rec3$:rec4$:rec5$:rec6$:rec7$:"); -$a[2] = "recZ"; # it kicks in here -check_autodeferring('ON'); -check_contents("recX$:recY$:rec2$:rec3$:rec4$:rec5$:rec6$:rec7$:"); - -# (23-26) Explicitly enabling deferred writing deactivates autodeferring -$o->defer; -check_autodeferring('OFF'); -check_contents("recX$:recY$:recZ$:rec3$:rec4$:rec5$:rec6$:rec7$:"); -$o->discard; -check_autodeferring('OFF'); - -# (27-32) Now let's try the CLEAR special case -@a = ("r0" .. "r4"); -check_autodeferring('ON'); -# The file was extended to the right length, but nothing was actually written. -check_contents("$:$:$:$:$:"); -$a[2] = "fish"; -check_autodeferring('OFF'); -check_contents("r0$:r1$:fish$:r3$:r4$:"); - -# (33-47) Now let's try the originally intended application: a 'for' loop. -my $it = 0; -for (@a) { - $_ = "##$_"; - if ($it == 0) { - check_autodeferring('OFF'); - check_contents("##r0$:r1$:fish$:r3$:r4$:"); - } elsif ($it == 1) { - check_autodeferring('OFF'); - check_contents("##r0$:##r1$:fish$:r3$:r4$:"); - } else { - check_autodeferring('ON'); - check_contents("##r0$:##r1$:fish$:r3$:r4$:"); - } - $it++; -} - -# (48-56) Autodeferring should not become active during explicit defer mode -$o->defer(); # This should flush the pending autodeferred records - # and deactivate autodeferring -check_autodeferring('OFF'); -check_contents("##r0$:##r1$:##fish$:##r3$:##r4$:"); -@a = ("s0" .. "s4"); -check_autodeferring('OFF'); -check_contents(""); -$o->flush; -check_autodeferring('OFF'); -check_contents("s0$:s1$:s2$:s3$:s4$:"); - -undef $o; untie @a; - -# Limit cache+buffer size to 47 bytes -my $MAX = 47; -# -- that's enough space for 5 records, but not 6, on both \n and \r\n systems -my $BUF = 20; -# -- that's enough space for 2 records, but not 3, on both \n and \r\n systems -# Re-tie the object for more tests -$o = tie @a, 'Tie::File', $file, autodefer => 0; -die $! unless $o; -# I am an undocumented feature -$o->{autodefer_filelen_threshhold} = 0; -# Normally autodeferring only works on large files. This disables that. - -# (57-59) Did the autodefer => 0 option work? -# (If it doesn't, a whole bunch of the other test files will fail.) -@a = (0..3); -check_autodeferring('OFF'); -check_contents(join("$:", qw(0 1 2 3), "")); - -# (60-62) Does the ->autodefer method work? -$o->autodefer(1); -@a = (10..13); -check_autodeferring('ON'); -check_contents("$:$:$:$:"); # This might be unfortunate. - -# (63-65) Does the ->autodefer method work? -$o->autodefer(0); -check_autodeferring('OFF'); -check_contents(join("$:", qw(10 11 12 13), "")); - - -sub check_autodeferring { - my ($x) = shift; - my $a = $o->{autodeferring} ? 'ON' : 'OFF'; - if ($x eq $a) { - print "ok $N\n"; - } else { - print "not ok $N \# Autodeferring was $a, expected it to be $x\n"; - } - $N++; -} - - -sub check_contents { - my $x = shift; -# for (values %{$o->{cache}}) { -# print "# cache=$_"; -# } - - my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY}); - local *FH = $o->{fh}; - seek FH, 0, SEEK_SET; - print $integrity ? "ok $N\n" : "not ok $N\n"; - $N++; - my $a; - { local $/; $a = <FH> } - $a = "" unless defined $a; - if ($a eq $x) { - print "ok $N\n"; - } else { - ctrlfix(my $msg = "# expected <$x>, got <$a>"); - print "not ok $N\n$msg\n"; - } - $N++; -} - -sub ctrlfix { - for (@_) { - s/\n/\\n/g; - s/\r/\\r/g; - } -} - -END { - undef $o; - untie @a; - 1 while unlink $file; -} - diff --git a/lib/Tie/File/t/32_defer_misc.t b/lib/Tie/File/t/32_defer_misc.t deleted file mode 100644 index e0e3f15bb8..0000000000 --- a/lib/Tie/File/t/32_defer_misc.t +++ /dev/null @@ -1,232 +0,0 @@ -#!/usr/bin/perl -# -# Check interactions of deferred writing -# with miscellaneous methods like DELETE, EXISTS, -# FETCHSIZE, STORESIZE, CLEAR, EXTEND -# - -use POSIX 'SEEK_SET'; -my $file = "tf$$.txt"; -$: = Tie::File::_default_recsep(); -my $data = "rec0$:rec1$:rec2$:"; -my ($o, $n); - -print "1..53\n"; - -my $N = 1; -use Tie::File; -print "ok $N\n"; $N++; - -open F, "> $file" or die $!; -binmode F; -print F $data; -close F; -$o = tie @a, 'Tie::File', $file; -print $o ? "ok $N\n" : "not ok $N\n"; -$N++; - -# (3-6) EXISTS -if ($] >= 5.006) { - eval << 'TESTS'; -$o->defer; -expect(not exists $a[4]); -$a[4] = "rec4"; -expect(exists $a[4]); -check_contents($data); # nothing written yet -$o->discard; -TESTS -} else { - for (3..6) { - print "ok $_ \# skipped (no exists for arrays)\n"; - $N++; - } -} - -# (7-10) FETCHSIZE -$o->defer; -expect($#a, 2); -$a[4] = "rec4"; -expect($#a, 4); -check_contents($data); # nothing written yet -$o->discard; - -# (11-21) STORESIZE -$o->defer; -$#a = 4; -check_contents($data); # nothing written yet -expect($#a, 4); -$o->flush; -expect($#a, 4); -check_contents("$data$:$:"); # two extra empty records - -$o->defer; -$a[4] = "rec4"; -$#a = 2; -expect($a[4], undef); -check_contents($data); # written data was unwritten -$o->flush; -check_contents($data); # nothing left to write - -# (22-28) CLEAR -$o->defer; -$a[9] = "rec9"; -check_contents($data); # nothing written yet -@a = (); -check_contents(""); # this happens right away -expect($a[9], undef); -$o->flush; -check_contents(""); # nothing left to write - -# (29-34) EXTEND -# Actually it's not real clear what these tests are for -# since EXTEND has no defined semantics -$o->defer; -@a = (0..3); -check_contents(""); # nothing happened yet -expect($a[3], "3"); -expect($a[4], undef); -$o->flush; -check_contents("0$:1$:2$:3$:"); # file now 4 records long - -# (35-53) DELETE -if ($] >= 5.006) { - eval << 'TESTS'; -my $del; -$o->defer; -$del = delete $a[2]; -check_contents("0$:1$:2$:3$:"); # nothing happened yet -expect($a[2], ""); -expect($del, "2"); -$del = delete $a[3]; # shortens file! -check_contents("0$:1$:2$:"); # deferred writes NOT flushed -expect($a[3], undef); -expect($a[2], ""); -expect($del, "3"); -$a[2] = "cookies"; -$del = delete $a[2]; # shortens file! -expect($a[2], undef); -expect($del, 'cookies'); -check_contents("0$:1$:"); -$a[0] = "crackers"; -$del = delete $a[0]; # file unchanged -expect($a[0], ""); -expect($del, 'crackers'); -check_contents("0$:1$:"); # no change yet -$o->flush; -check_contents("$:1$:"); # record 0 is NOT 'cookies'; -TESTS -} else { - for (35..53) { - print "ok $_ \# skipped (no delete for arrays)\n"; - $N++; - } -} - -################################################################ - - -sub check_caches { - my ($xcache, $xdefer) = @_; - -# my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY}); -# print $integrity ? "ok $N\n" : "not ok $N\n"; -# $N++; - - my $good = 1; - $good &&= hash_equal($o->{cache}, $xcache, "true cache", "expected cache"); - $good &&= hash_equal($o->{deferred}, $xdefer, "true defer", "expected defer"); - print $good ? "ok $N\n" : "not ok $N\n"; - $N++; -} - -sub hash_equal { - my ($a, $b, $ha, $hb) = @_; - $ha = 'first hash' unless defined $ha; - $hb = 'second hash' unless defined $hb; - - my $good = 1; - my %b_seen; - - for my $k (keys %$a) { - if (! exists $b->{$k}) { - print ctrlfix("# Key $k is in $ha but not $hb"), "\n"; - $good = 0; - } elsif ($b->{$k} ne $a->{$k}) { - print ctrlfix("# Key $k is <$a->{$k}> in $ha but <$b->{$k}> in $hb"), "\n"; - $b_seen{$k} = 1; - $good = 0; - } else { - $b_seen{$k} = 1; - } - } - - for my $k (keys %$b) { - unless ($b_seen{$k}) { - print ctrlfix("# Key $k is in $hb but not $ha"), "\n"; - $good = 0; - } - } - - $good; -} - - -sub check_contents { - my $x = shift; - - my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY}); - print $integrity ? "ok $N\n" : "not ok $N\n"; - $N++; - - local *FH = $o->{fh}; - seek FH, 0, SEEK_SET; - - my $a; - { local $/; $a = <FH> } - $a = "" unless defined $a; - if ($a eq $x) { - print "ok $N\n"; - } else { - my $msg = ctrlfix("# expected <$x>, got <$a>"); - print "not ok $N\n$msg\n"; - } - $N++; -} - -sub expect { - if (@_ == 1) { - print $_[0] ? "ok $N\n" : "not ok $N\n"; - } elsif (@_ == 2) { - my ($a, $x) = @_; - if (! defined($a) && ! defined($x)) { print "ok $N\n" } - elsif ( defined($a) && ! defined($x)) { - ctrlfix(my $msg = "expected UNDEF, got <$a>"); - print "not ok $N \# $msg\n"; - } - elsif (! defined($a) && defined($x)) { - ctrlfix(my $msg = "expected <$x>, got UNDEF"); - print "not ok $N \# $msg\n"; - } elsif ($a eq $x) { print "ok $N\n" } - else { - ctrlfix(my $msg = "expected <$x>, got <$a>"); - print "not ok $N \# $msg\n"; - } - } else { - die "expect() got ", scalar(@_), " args, should have been 1 or 2"; - } - $N++; -} - -sub ctrlfix { - local $_ = shift; - s/\n/\\n/g; - s/\r/\\r/g; - $_; -} - -END { - undef $o; - untie @a; - 1 while unlink $file; -} - diff --git a/lib/Tie/File/t/33_defer_vs.t b/lib/Tie/File/t/33_defer_vs.t deleted file mode 100644 index 071af77a68..0000000000 --- a/lib/Tie/File/t/33_defer_vs.t +++ /dev/null @@ -1,125 +0,0 @@ -#!/usr/bin/perl -# -# Deferred caching of varying size records -# -# 30_defer.t always uses records that are 8 bytes long -# (9 on \r\n machines.) We might miss some sort of -# length-calculation bug as a result. This file will run some of the same -# tests, but with with varying-length records. -# - -use POSIX 'SEEK_SET'; -my $file = "tf$$.txt"; -# print "1..0\n"; exit; -$: = Tie::File::_default_recsep(); -my $data = "$:1$:22$:"; -my ($o, $n); - -print "1..30\n"; - -my $N = 1; -use Tie::File; -print "ok $N\n"; $N++; - -open F, "> $file" or die $!; -binmode F; -print F $data; -close F; -$o = tie @a, 'Tie::File', $file; -print $o ? "ok $N\n" : "not ok $N\n"; -$N++; - -# (3-6) Deferred storage -$o->defer; -$a[3] = "333"; -check_contents($data); # nothing written yet -$a[4] = "4444"; -check_contents($data); # nothing written yet - -# (7-8) Flush -$o->flush; -check_contents($data . "333$:4444$:"); # now it's written - -# (9-12) Deferred writing disabled? -$a[3] = "999999999"; -check_contents("${data}999999999$:4444$:"); -$a[4] = "88888888"; -check_contents("${data}999999999$:88888888$:"); - -# (13-18) Now let's try two batches of records -$#a = 2; -$o->defer; -$a[0] = "55555"; -check_contents($data); # nothing written yet -$a[2] = "aaaaaaaaaa"; -check_contents($data); # nothing written yet -$o->flush; -check_contents("55555$:1$:aaaaaaaaaa$:"); - -# (19-22) Deferred writing past the end of the file -$o->defer; -$a[4] = "7777777"; -check_contents("55555$:1$:aaaaaaaaaa$:"); -$o->flush; -check_contents("55555$:1$:aaaaaaaaaa$:$:7777777$:"); - - -# (23-26) Now two long batches -$o->defer; -%l = qw(0 2 1 3 2 4 4 5 5 4 6 3); -for (0..2, 4..6) { - $a[$_] = $_ x $l{$_}; -} -check_contents("55555$:1$:aaaaaaaaaa$:$:7777777$:"); -$o->flush; -check_contents(join $:, "00", "111", "2222", "", "44444", "5555", "666", ""); - -# (27-30) Now let's make sure that discarded writes are really discarded -# We have a 2Mib buffer here, so we can be sure that we aren't accidentally -# filling it up -$o->defer; -for (0, 3, 7) { - $a[$_] = "discarded" . $_ x $_; -} -check_contents(join $:, "00", "111", "2222", "", "44444", "5555", "666", ""); -$o->discard; -check_contents(join $:, "00", "111", "2222", "", "44444", "5555", "666", ""); - -################################################################ - - -sub check_contents { - my $x = shift; - - my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY}); - print $integrity ? "ok $N\n" : "not ok $N\n"; - $N++; - - local *FH = $o->{fh}; - seek FH, 0, SEEK_SET; - - my $a; - { local $/; $a = <FH> } - $a = "" unless defined $a; - if ($a eq $x) { - print "ok $N\n"; - } else { - my $msg = ctrlfix("# expected <$x>, got <$a>"); - print "not ok $N\n$msg\n"; - } - $N++; -} - -sub ctrlfix { - local $_ = shift; - s/\n/\\n/g; - s/\r/\\r/g; - $_; -} - -END { - undef $o; - untie @a; - 1 while unlink $file; -} - diff --git a/lib/Tie/File/t/40_abs_cache.t b/lib/Tie/File/t/40_abs_cache.t deleted file mode 100644 index 137c9bb78d..0000000000 --- a/lib/Tie/File/t/40_abs_cache.t +++ /dev/null @@ -1,281 +0,0 @@ -#!/usr/bin/perl -# -# Unit tests for abstract cache implementation -# -# Test the following methods: -# * new() -# * is_empty() -# * empty() -# * lookup(key) -# * remove(key) -# * insert(key,val) -# * update(key,val) -# * rekey(okeys,nkeys) -# * expire() -# * keys() -# * bytes() -# DESTROY() -# -# 20020327 You somehow managed to miss: -# * reduce_size_to(bytes) -# - -# print "1..0\n"; exit; -print "1..42\n"; - -my ($N, @R, $Q, $ar) = (1); - -use Tie::File; -print "ok $N\n"; -$N++; - -my $h = Tie::File::Cache->new(10000) or die; -print "ok $N\n"; -$N++; - -# (3) Are all the methods there? -{ - my $good = 1; - for my $meth (qw(new is_empty empty lookup remove - insert update rekey expire ckeys bytes - set_limit adj_limit flush reduce_size_to - _produce _produce_lru )) { - unless ($h->can($meth)) { - print STDERR "# Method '$meth' is missing.\n"; - $good = 0; - } - } - print $good ? "ok $N\n" : "not ok $N\n"; - $N++; -} - -# (4-5) Straight insert and removal FIFO test -$ar = 'a0'; -for (1..10) { - $h->insert($_, $ar++); -} -1; -for (1..10) { - push @R, $h->expire; -} -$iota = iota('a',9); -print "@R" eq $iota - ? "ok $N\n" : "not ok $N \# expected ($iota), got (@R)\n"; -$N++; -check($h); - -# (6-7) Remove from empty heap -$n = $h->expire; -print ! defined $n ? "ok $N\n" : "not ok $N \# expected UNDEF, got $n"; -$N++; -check($h); - -# (8-9) Interleaved insert and removal -$Q = 0; -@R = (); -for my $i (1..4) { - for my $j (1..$i) { - $h->insert($Q, "b$Q"); - $Q++; - } - for my $j (1..$i) { - push @R, $h->expire; - } -} -$iota = iota('b', 9); -print "@R" eq $iota ? "ok $N\n" : "not ok $N \# expected ($iota), got (@R)\n"; -$N++; -check($h); - -# (10) It should be empty now -print $h->is_empty ? "ok $N\n" : "not ok $N\n"; -$N++; - -# (11-12) Insert and delete -$Q = 1; -for (1..10) { - $h->insert($_, "c$Q"); - $Q++; -} -for (2, 4, 6, 8, 10) { - $h->remove($_); -} -@R = (); -push @R, $n while defined ($n = $h->expire); -print "@R" eq "c1 c3 c5 c7 c9" ? - "ok $N\n" : "not ok $N \# expected (c1 c3 c5 c7 c9), got (@R)\n"; -$N++; -check($h); - -# (13-14) Interleaved insert and delete -$Q = 1; my $QQ = 1; -@R = (); -for my $i (1..4) { - for my $j (1..$i) { - $h->insert($Q, "d$Q"); - $Q++; - } - for my $j (1..$i) { - $h->remove($QQ) if $QQ % 2 == 0; - $QQ++; - } -} -push @R, $n while defined ($n = $h->expire); -print "@R" eq "d1 d3 d5 d7 d9" ? - "ok $N\n" : "not ok $N \# expected (d1 d3 d5 d7 d9), got (@R)\n"; -$N++; -check($h); - -# (15-16) Promote -$h->empty; -$Q = 1; -for (1..10) { - $h->insert($_, "e$Q"); - unless ($h->_check_integrity) { - die "Integrity failed after inserting ($_, e$Q)\n"; - } - $Q++; -} -1; -for (2, 4, 6, 8, 10) { - $h->_promote($_); -} -@R = (); -push @R, $n while defined ($n = $h->expire); -print "@R" eq "e1 e3 e5 e7 e9 e2 e4 e6 e8 e10" ? - "ok $N\n" : - "not ok $N \# expected (e1 e3 e5 e7 e9 e2 e4 e6 e8 e10), got (@R)\n"; -$N++; -check($h); - -# (17-22) Lookup -$Q = 1; -for (1..10) { - $h->insert($_, "f$Q"); - $Q++; -} -1; -for (2, 4, 6, 4, 8) { - my $r = $h->lookup($_); - print $r eq "f$_" ? "ok $N\n" : "not ok $N \# expected f$_, got $r\n"; - $N++; -} -check($h); - -# (23) It shouldn't be empty -print ! $h->is_empty ? "ok $N\n" : "not ok $N\n"; -$N++; - -# (24-25) Lookup should have promoted the looked-up records -@R = (); -push @R, $n while defined ($n = $h->expire); -print "@R" eq "f1 f3 f5 f7 f9 f10 f2 f6 f4 f8" ? - "ok $N\n" : - "not ok $N \# expected (f1 f3 f5 f7 f9 f10 f2 f6 f4 f8), got (@R)\n"; -$N++; -check($h); - -# (26-29) Typical 'rekey' operation -$Q = 1; -for (1..10) { - $h->insert($_, "g$Q"); - $Q++; -} -$h->rekey([6,7,8,9,10], [8,9,10,11,12]); -my %x = qw(1 g1 2 g2 3 g3 4 g4 5 g5 - 8 g6 9 g7 10 g8 11 g9 12 g10); -{ - my $good = 1; - for my $k (keys %x) { - my $v = $h->lookup($k); - $v = "UNDEF" unless defined $v; - unless ($v eq $x{$k}) { - print "# looked up $k, got $v, expected $x{$k}\n"; - $good = 0; - } - } - print $good ? "ok $N\n" : "not ok $N\n"; - $N++; -} -check($h); -{ - my $good = 1; - for my $k (6, 7) { - my $v = $h->lookup($k); - if (defined $v) { - print "# looked up $k, got $v, should have been undef\n"; - $good = 0; - } - } - print $good ? "ok $N\n" : "not ok $N\n"; - $N++; -} -check($h); - -# (30-31) ckeys -@R = sort { $a <=> $b } $h->ckeys; -print "@R" eq "1 2 3 4 5 8 9 10 11 12" ? - "ok $N\n" : - "not ok $N \# expected (1 2 3 4 5 8 9 10 11 12) got (@R)\n"; -$N++; -check($h); -1; -# (32-33) update -for (1..5, 8..12) { - $h->update($_, "h$_"); -} -@R = (); -for (sort { $a <=> $b } $h->ckeys) { - push @R, $h->lookup($_); -} -print "@R" eq "h1 h2 h3 h4 h5 h8 h9 h10 h11 h12" ? - "ok $N\n" : - "not ok $N \# expected (h1 h2 h3 h4 h5 h8 h9 h10 h11 h12) got (@R)\n"; -$N++; -check($h); - -# (34-37) bytes -my $B; -$B = $h->bytes; -print $B == 23 ? "ok $N\n" : "not ok $N \# expected 23, got $B\n"; -$N++; -check($h); -$h->update('12', "yobgorgle"); -$B = $h->bytes; -print $B == 29 ? "ok $N\n" : "not ok $N \# expected 29, got $B\n"; -$N++; -check($h); - -# (38-41) empty -$h->empty; -print $h->is_empty ? "ok $N\n" : "not ok $N\n"; -$N++; -check($h); -$n = $h->expire; -print ! defined $n ? "ok $N\n" : "not ok $N \# expected UNDEF, got $n"; -$N++; -check($h); - -# (42) very weak testing of DESTROY -undef $h; -# are we still alive? -print "ok $N\n"; -$N++; - -sub check { - my $h = shift; - print $h->_check_integrity ? "ok $N\n" : "not ok $N\n"; - $N++; -} - -sub iota { - my ($p, $n) = @_; - my $r; - my $i = 0; - while ($i <= $n) { - $r .= "$p$i "; - $i++; - } - chop $r; - $r; -} diff --git a/lib/Tie/File/t/41_heap.t b/lib/Tie/File/t/41_heap.t deleted file mode 100644 index 9e7ad2516c..0000000000 --- a/lib/Tie/File/t/41_heap.t +++ /dev/null @@ -1,259 +0,0 @@ -#!/usr/bin/perl -# -# Unit tests for heap implementation -# -# Test the following methods: -# new -# is_empty -# empty -# insert -# remove -# popheap -# promote -# lookup -# set_val -# rekey -# expire_order - - -# Finish these later. - -# They're nonurgent because the important heap stuff is extensively -# tested by tests 19, 20, 24, 30, 32, 33, and 40, as well as by pretty -# much everything else. -print "1..1\n"; - - -my ($N, @R, $Q, $ar) = (1); - -use Tie::File; -print "ok $N\n"; -$N++; -exit; - -__END__ - -my @HEAP_MOVE; -sub Fake::Cache::_heap_move { push @HEAP_MOVE, @_ } - -my $h = Tie::File::Heap->new(bless [] => 'Fake::Cache'); -print "ok $N\n"; -$N++; - -# (3) Are all the methods there? -{ - my $good = 1; - for my $meth (qw(new is_empty empty lookup insert remove popheap - promote set_val rekey expire_order)) { - unless ($h->can($meth)) { - print STDERR "# Method '$meth' is missing.\n"; - $good = 0; - } - } - print $good ? "ok $N\n" : "not ok $N\n"; - $N++; -} - -# (4) Straight insert and removal FIFO test -$ar = 'a0'; -for (1..10) { - $h->insert($_, $ar++); -} -for (1..10) { - push @R, $h->popheap; -} -$iota = iota('a',9); -print "@R" eq $iota - ? "ok $N\n" : "not ok $N \# expected ($iota), got (@R)\n"; -$N++; - -# (5) Remove from empty heap -$n = $h->popheap; -print ! defined $n ? "ok $N\n" : "not ok $N \# expected UNDEF, got $n"; -$N++; - -# (6) Interleaved insert and removal -$Q = 0; -@R = (); -for my $i (1..4) { - for my $j (1..$i) { - $h->insert($Q, "b$Q"); - $Q++; - } - for my $j (1..$i) { - push @R, $h->popheap; - } -} -$iota = iota('b', 9); -print "@R" eq $iota ? "ok $N\n" : "not ok $N \# expected ($iota), got (@R)\n"; -$N++; - -# (7) It should be empty now -print $h->is_empty ? "ok $N\n" : "not ok $N\n"; -$N++; - -# (8) Insert and delete -$Q = 1; -for (1..10) { - $h->insert($_, "c$Q"); - $Q++; -} -for (2, 4, 6, 8, 10) { - $h->remove($_); -} -@R = (); -push @R, $n while defined ($n = $h->popheap); -print "@R" eq "c1 c3 c5 c7 c9" ? - "ok $N\n" : "not ok $N \# expected (c1 c3 c5 c7 c9), got (@R)\n"; -$N++; - -# (9) Interleaved insert and delete -$Q = 1; my $QQ = 1; -@R = (); -for my $i (1..4) { - for my $j (1..$i) { - $h->insert($Q, "d$Q"); - $Q++; - } - for my $j (1..$i) { - $h->remove($QQ) if $QQ % 2 == 0; - $QQ++; - } -} -push @R, $n while defined ($n = $h->popheap); -print "@R" eq "d1 d3 d5 d7 d9" ? - "ok $N\n" : "not ok $N \# expected (d1 d3 d5 d7 d9), got (@R)\n"; -$N++; - -# (10) Promote -$Q = 1; -for (1..10) { - $h->insert($_, "e$Q"); - $Q++; -} -for (2, 4, 6, 8, 10) { - $h->promote($_); -} -@R = (); -push @R, $n while defined ($n = $h->popheap); -print "@R" eq "e1 e3 e5 e7 e9 e2 e4 e6 e8 e10" ? - "ok $N\n" : - "not ok $N \# expected (e1 e3 e5 e7 e9 e2 e4 e6 e8 e10), got (@R)\n"; -$N++; - -# (11-15) Lookup -$Q = 1; -for (1..10) { - $h->insert($_, "f$Q"); - $Q++; -} -for (2, 4, 6, 4, 8) { - my $r = $h->lookup($_); - print $r eq "f$_" ? "ok $N\n" : "not ok $N \# expected f$_, got $r\n"; - $N++; -} - -# (16) It shouldn't be empty -print ! $h->is_empty ? "ok $N\n" : "not ok $N\n"; -$N++; - -# (17) Lookup should have promoted the looked-up records -@R = (); -push @R, $n while defined ($n = $h->popheap); -print "@R" eq "f1 f3 f5 f7 f9 f10 f2 f6 f4 f8" ? - "ok $N\n" : - "not ok $N \# expected (f1 f3 f5 f7 f9 f10 f2 f6 f4 f8), got (@R)\n"; -$N++; - -# (18-19) Typical 'rekey' operation -$Q = 1; -for (1..10) { - $h->insert($_, "g$Q"); - $Q++; -} - -$h->rekey([6,7,8,9,10], [8,9,10,11,12]); -my %x = qw(1 g1 2 g2 3 g3 4 g4 5 g5 - 8 g6 9 g7 10 g8 11 g9 12 g10); -{ - my $good = 1; - for my $k (keys %x) { - my $v = $h->lookup($k); - $v = "UNDEF" unless defined $v; - unless ($v eq $x{$k}) { - print "# looked up $k, got $v, expected $x{$k}\n"; - $good = 0; - } - } - print $good ? "ok $N\n" : "not ok $N\n"; - $N++; -} -{ - my $good = 1; - for my $k (6, 7) { - my $v = $h->lookup($k); - if (defined $v) { - print "# looked up $k, got $v, should have been undef\n"; - $good = 0; - } - } - print $good ? "ok $N\n" : "not ok $N\n"; - $N++; -} - -# (20) keys -@R = sort { $a <=> $b } $h->keys; -print "@R" eq "1 2 3 4 5 8 9 10 11 12" ? - "ok $N\n" : - "not ok $N \# expected (1 2 3 4 5 8 9 10 11 12) got (@R)\n"; -$N++; - -# (21) update -for (1..5, 8..12) { - $h->update($_, "h$_"); -} -@R = (); -for (sort { $a <=> $b } $h->keys) { - push @R, $h->lookup($_); -} -print "@R" eq "h1 h2 h3 h4 h5 h8 h9 h10 h11 h12" ? - "ok $N\n" : - "not ok $N \# expected (h1 h2 h3 h4 h5 h8 h9 h10 h11 h12) got (@R)\n"; -$N++; - -# (22-23) bytes -my $B; -$B = $h->bytes; -print $B == 23 ? "ok $N\n" : "not ok $N \# expected 23, got $B\n"; -$N++; -$h->update('12', "yobgorgle"); -$B = $h->bytes; -print $B == 29 ? "ok $N\n" : "not ok $N \# expected 29, got $B\n"; -$N++; - -# (24-25) empty -$h->empty; -print $h->is_empty ? "ok $N\n" : "not ok $N\n"; -$N++; -$n = $h->popheap; -print ! defined $n ? "ok $N\n" : "not ok $N \# expected UNDEF, got $n"; -$N++; - -# (26) very weak testing of DESTROY -undef $h; -# are we still alive? -print "ok $N\n"; -$N++; - - -sub iota { - my ($p, $n) = @_; - my $r; - my $i = 0; - while ($i <= $n) { - $r .= "$p$i "; - $i++; - } - chop $r; - $r; -} diff --git a/lib/Tie/File/t/42_offset.t b/lib/Tie/File/t/42_offset.t deleted file mode 100644 index 1762443482..0000000000 --- a/lib/Tie/File/t/42_offset.t +++ /dev/null @@ -1,74 +0,0 @@ -#!/usr/bin/perl - -# 2003-04-09 Tels: test the offset method from 0.94 - -use Test::More; -use strict; -use File::Spec; - -use POSIX 'SEEK_SET'; -my $file = "tf$$.txt"; - -BEGIN - { - $| = 1; - if ($ENV{PERL_CORE}) - { - # testing with the core distribution - @INC = ( File::Spec->catdir(File::Spec->updir, 't', 'lib') ); - } - unshift @INC, File::Spec->catdir(File::Spec->updir, 'lib'); - chdir 't' if -d 't'; - print "# INC = @INC\n"; - - plan tests => 24; - - use_ok ('Tie::File'); - } - -$/ = "#"; # avoid problems with \n\r vs. \n - -my @a; -my $o = tie @a, 'Tie::File', $file, autodefer => 0; - -is (ref($o), 'Tie::File'); - -is ($o->offset(0), 0, 'first one always there'); -is ($o->offset(1), undef, 'no offsets yet'); - -$a[0] = 'Bourbon'; -is ($o->offset(0), 0, 'first is ok'); -is ($o->offset(1), 8, 'and second ok'); -is ($o->offset(2), undef, 'third undef'); - -$a[1] = 'makes'; -is ($o->offset(0), 0, 'first is ok'); -is ($o->offset(1), 8, 'and second ok'); -is ($o->offset(2), 14, 'and third ok'); -is ($o->offset(3), undef, 'fourth undef'); - -$a[2] = 'the baby'; -is ($o->offset(0), 0, 'first is ok'); -is ($o->offset(1), 8, 'and second ok'); -is ($o->offset(2), 14, 'and third ok'); -is ($o->offset(3), 23, 'and fourth ok'); -is ($o->offset(4), undef, 'fourth undef'); - -$a[3] = 'grin'; -is ($o->offset(0), 0, 'first is ok'); -is ($o->offset(1), 8, 'and second ok'); -is ($o->offset(2), 14, 'and third ok'); -is ($o->offset(3), 23, 'and fourth ok'); -is ($o->offset(4), 28, 'and fifth ok'); - -$a[4] = '!'; -is ($o->offset(5), 30, 'and fifth ok'); -$a[3] = 'water'; -is ($o->offset(4), 29, 'and fourth changed ok'); -is ($o->offset(5), 31, 'and fifth ok'); - -END { - undef $o; - untie @a; - 1 while unlink $file; -} |