1N/A#!/usr/bin/perl
1N/A
1N/Amy $file = "tf$$.txt";
1N/A
1N/Aprint "1..59\n";
1N/A
1N/Amy $N = 1;
1N/Ause Tie::File;
1N/Aprint "ok $N\n"; $N++;
1N/A
1N/A$RECSEP = 'blah';
1N/Amy $o = tie @a, 'Tie::File', $file,
1N/A recsep => $RECSEP, autochomp => 0, autodefer => 0;
1N/Aprint $o ? "ok $N\n" : "not ok $N\n";
1N/A$N++;
1N/A
1N/A
1N/A# 3-4 create
1N/A$a[0] = 'rec0';
1N/Acheck_contents("rec0");
1N/A
1N/A# 5-8 append
1N/A$a[1] = 'rec1';
1N/Acheck_contents("rec0", "rec1");
1N/A$a[2] = 'rec2';
1N/Acheck_contents("rec0", "rec1", "rec2");
1N/A
1N/A# 9-14 same-length alterations
1N/A$a[0] = 'new0';
1N/Acheck_contents("new0", "rec1", "rec2");
1N/A$a[1] = 'new1';
1N/Acheck_contents("new0", "new1", "rec2");
1N/A$a[2] = 'new2';
1N/Acheck_contents("new0", "new1", "new2");
1N/A
1N/A# 15-24 lengthening alterations
1N/A$a[0] = 'long0';
1N/Acheck_contents("long0", "new1", "new2");
1N/A$a[1] = 'long1';
1N/Acheck_contents("long0", "long1", "new2");
1N/A$a[2] = 'long2';
1N/Acheck_contents("long0", "long1", "long2");
1N/A$a[1] = 'longer1';
1N/Acheck_contents("long0", "longer1", "long2");
1N/A$a[0] = 'longer0';
1N/Acheck_contents("longer0", "longer1", "long2");
1N/A
1N/A# 25-34 shortening alterations, including truncation
1N/A$a[0] = 'short0';
1N/Acheck_contents("short0", "longer1", "long2");
1N/A$a[1] = 'short1';
1N/Acheck_contents("short0", "short1", "long2");
1N/A$a[2] = 'short2';
1N/Acheck_contents("short0", "short1", "short2");
1N/A$a[1] = 'sh1';
1N/Acheck_contents("short0", "sh1", "short2");
1N/A$a[0] = 'sh0';
1N/Acheck_contents("sh0", "sh1", "short2");
1N/A
1N/A# (35-38) file with holes
1N/A$a[4] = 'rec4';
1N/Acheck_contents("sh0", "sh1", "short2", "", "rec4");
1N/A$a[3] = 'rec3';
1N/Acheck_contents("sh0", "sh1", "short2", "rec3", "rec4");
1N/A
1N/A# (39-40) zero out file
1N/A@a = ();
1N/Acheck_contents();
1N/A
1N/A# (41-42) insert into the middle of an empty file
1N/A$a[3] = "rec3";
1N/Acheck_contents("", "", "", "rec3");
1N/A
1N/A# (43-47) 20020326 You thought there would be a bug in STORE where if
1N/A# a cached record was false, STORE wouldn't see it at all. Yup, there is,
1N/A# and adding the appropriate defined() test fixes the problem.
1N/Aundef $o; untie @a; 1 while unlink $file;
1N/A$RECSEP = '0';
1N/A$o = tie @a, 'Tie::File', $file,
1N/A recsep => $RECSEP, autochomp => 0, autodefer => 0;
1N/Aprint $o ? "ok $N\n" : "not ok $N\n";
1N/A$N++;
1N/A$#a = 2;
1N/Amy $z = $a[1]; # caches "0"
1N/A$a[2] = "oops";
1N/Acheck_contents("", "", "oops");
1N/A$a[1] = "bah";
1N/Acheck_contents("", "bah", "oops");
1N/Aundef $o; untie @a;
1N/A
1N/A# (48-56) 20020331 Make sure we correctly handle the case where the final
1N/A# record of the file is not properly terminated, Through version 0.90,
1N/A# we would mangle the file.
1N/Amy $badrec = "Malformed";
1N/A$: = $RECSEP = Tie::File::_default_recsep();
1N/A# (48-50)
1N/Aif (setup_badly_terminated_file(3)) {
1N/A $o = tie @a, 'Tie::File', $file,
1N/A recsep => $RECSEP, autochomp => 0, autodefer => 0
1N/A or die "Couldn't tie file: $!";
1N/A my $z = $a[0];
1N/A print $z eq "$badrec$:" ? "ok $N\n" :
1N/A "not ok $N \# got $z, expected $badrec\n";
1N/A $N++;
1N/A push @a, "next";
1N/A check_contents($badrec, "next");
1N/A}
1N/A# (51-52)
1N/Aif (setup_badly_terminated_file(2)) {
1N/A $o = tie @a, 'Tie::File', $file,
1N/A recsep => $RECSEP, autochomp => 0, autodefer => 0
1N/A or die "Couldn't tie file: $!";
1N/A splice @a, 1, 0, "x", "y";
1N/A check_contents($badrec, "x", "y");
1N/A}
1N/A# (53-56)
1N/Aif (setup_badly_terminated_file(4)) {
1N/A $o = tie @a, 'Tie::File', $file,
1N/A recsep => $RECSEP, autochomp => 0, autodefer => 0
1N/A or die "Couldn't tie file: $!";
1N/A my @r = splice @a, 0, 1, "x", "y";
1N/A my $n = @r;
1N/A print $n == 1 ? "ok $N\n" : "not ok $N \# expected 1 elt, got $n\n";
1N/A $N++;
1N/A print $r[0] eq "$badrec$:" ? "ok $N\n"
1N/A : "not ok $N \# expected <$badrec>, got <$r[0]>\n";
1N/A $N++;
1N/A check_contents("x", "y");
1N/A}
1N/A
1N/A# (57-58) 20020402 The modification would have failed if $\ were set wrong.
1N/A# I hate $\.
1N/Aif (setup_badly_terminated_file(2)) {
1N/A $o = tie @a, 'Tie::File', $file,
1N/A recsep => $RECSEP, autochomp => 0, autodefer => 0
1N/A or die "Couldn't tie file: $!";
1N/A { local $\ = "I hate \$\\.";
1N/A my $z = $a[0];
1N/A }
1N/A check_contents($badrec);
1N/A}
1N/A
1N/A# (59) 20030527 Tom Christiansen pointed out that FETCH returns the wrong
1N/A# data on the final record of an unterminated file if the file is opened
1N/A# in read-only mode. Note that the $#a is necessary here.
1N/A# There's special-case code to fix the final record when it is read normally.
1N/A# But the $#a forces it to be read from the cache, which skips the
1N/A# termination.
1N/A$badrec = "world${RECSEP}hello";
1N/Aif (setup_badly_terminated_file(1)) {
1N/A tie(@a, "Tie::File", $file, mode => 0, recsep => $RECSEP)
1N/A or die "Couldn't tie file: $!";
1N/A my $z = $#a;
1N/A $z = $a[1];
1N/A print $z eq "hello" ? "ok $N\n" :
1N/A "not ok $N \# got $z, expected hello\n";
1N/A $N++;
1N/A}
1N/A
1N/Asub setup_badly_terminated_file {
1N/A my $NTESTS = shift;
1N/A open F, "> $file" or die "Couldn't open $file: $!";
1N/A binmode F;
1N/A print F $badrec;
1N/A close F;
1N/A unless (-s $file == length $badrec) {
1N/A for (1 .. $NTESTS) {
1N/A print "ok $N \# skipped - can't create improperly terminated file\n";
1N/A $N++;
1N/A }
1N/A return;
1N/A }
1N/A return 1;
1N/A}
1N/A
1N/A
1N/Ause POSIX 'SEEK_SET';
1N/Asub check_contents {
1N/A my @c = @_;
1N/A my $x = join $RECSEP, @c, '';
1N/A local *FH = $o->{fh};
1N/A seek FH, 0, SEEK_SET;
1N/A my $a;
1N/A { local $/; $a = <FH> }
1N/A
1N/A $a = "" unless defined $a;
1N/A if ($a eq $x) {
1N/A print "ok $N\n";
1N/A } else {
1N/A my $msg = "# expected <$x>, got <$a>";
1N/A ctrlfix($msg);
1N/A print "not ok $N $msg\n";
1N/A }
1N/A $N++;
1N/A
1N/A # now check FETCH:
1N/A my $good = 1;
1N/A for (0.. $#c) {
1N/A unless ($a[$_] eq "$c[$_]$RECSEP") {
1N/A $msg = "expected $c[$_]$RECSEP, got $a[$_]";
1N/A ctrlfix($msg);
1N/A $good = 0;
1N/A }
1N/A }
1N/A print $good ? "ok $N\n" : "not ok $N # fetch $msg\n";
1N/A $N++;
1N/A}
1N/A
1N/A
1N/Asub ctrlfix {
1N/A for (@_) {
1N/A s/\n/\\n/g;
1N/A s/\r/\\r/g;
1N/A }
1N/A}
1N/A
1N/A
1N/AEND {
1N/A undef $o;
1N/A untie @a;
1N/A 1 while unlink $file;
1N/A}
1N/A