1N/A#!/usr/bin/perl
1N/A
1N/Amy $file = "tf$$.txt";
1N/A$: = Tie::File::_default_recsep();
1N/A
1N/Aprint "1..71\n";
1N/A
1N/Amy $N = 1;
1N/Ause Tie::File;
1N/Aprint "ok $N\n"; $N++;
1N/A
1N/Amy $o = tie @a, 'Tie::File', $file, autochomp => 1, autodefer => 0;
1N/Aprint $o ? "ok $N\n" : "not ok $N\n";
1N/A$N++;
1N/A
1N/A# 3-5 create
1N/A$a[0] = 'rec0';
1N/Acheck_contents("rec0");
1N/A
1N/A# 6-11 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# 12-20 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# 21-35 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# 36-50 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# (51-56) 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# (57-59) zero out file
1N/A@a = ();
1N/Acheck_contents();
1N/A
1N/A# (60-62) insert into the middle of an empty file
1N/A$a[3] = "rec3";
1N/Acheck_contents("", "", "", "rec3");
1N/A
1N/A# (63-68) Test the ->autochomp() method
1N/A@a = qw(Gold Frankincense Myrrh);
1N/Amy $ac;
1N/A$ac = $o->autochomp();
1N/Aexpect($ac);
1N/A# See if that accidentally changed it
1N/A$ac = $o->autochomp();
1N/Aexpect($ac);
1N/A# Now clear it
1N/A$ac = $o->autochomp(0);
1N/Aexpect($ac);
1N/Aexpect(join("-", @a), "Gold$:-Frankincense$:-Myrrh$:");
1N/A# Now set it again
1N/A$ac = $o->autochomp(1);
1N/Aexpect(!$ac);
1N/Aexpect(join("-", @a), "Gold-Frankincense-Myrrh");
1N/A
1N/A# (69) Does 'splice' work correctly with autochomp?
1N/Amy @sr;
1N/A@sr = splice @a, 0, 2;
1N/Aexpect(join("-", @sr), "Gold-Frankincense");
1N/A
1N/A# (70-71) Didn't you forget that fetch may return an unchomped cached record?
1N/A$a1 = $a[0]; # populate cache
1N/A$a2 = $a[0];
1N/Aexpect($a1, "Myrrh");
1N/Aexpect($a2, "Myrrh");
1N/A# Actually no, you didn't---_fetch might return such a record, but
1N/A# the chomping is done by FETCH.
1N/A
1N/Ause POSIX 'SEEK_SET';
1N/Asub check_contents {
1N/A my @c = @_;
1N/A my $x = join $:, @c, '';
1N/A local *FH = $o->{fh};
1N/A seek FH, 0, SEEK_SET;
1N/A# my $open = open FH, "< $file";
1N/A my $a;
1N/A { local $/; $a = <FH> }
1N/A $a = "" unless defined $a;
1N/A if ($a eq $x) {
1N/A print "ok $N\n";
1N/A } else {
1N/A ctrlfix($a, $x);
1N/A print "not ok $N\n# expected <$x>, got <$a>\n";
1N/A }
1N/A $N++;
1N/A
1N/A # now check FETCH:
1N/A my $good = 1;
1N/A my $msg;
1N/A for (0.. $#c) {
1N/A my $aa = $a[$_];
1N/A unless ($aa eq $c[$_]) {
1N/A $msg = "expected <$c[$_]>, got <$aa>";
1N/A ctrlfix($msg);
1N/A $good = 0;
1N/A }
1N/A }
1N/A print $good ? "ok $N\n" : "not ok $N # $msg\n";
1N/A $N++;
1N/A
1N/A print $o->_check_integrity($file, $ENV{INTEGRITY})
1N/A ? "ok $N\n" : "not ok $N\n";
1N/A $N++;
1N/A}
1N/A
1N/Asub expect {
1N/A if (@_ == 1) {
1N/A print $_[0] ? "ok $N\n" : "not ok $N\n";
1N/A } elsif (@_ == 2) {
1N/A my ($a, $x) = @_;
1N/A if (! defined($a) && ! defined($x)) { print "ok $N\n" }
1N/A elsif ( defined($a) && ! defined($x)) {
1N/A ctrlfix(my $msg = "expected UNDEF, got <$a>");
1N/A print "not ok $N \# $msg\n";
1N/A }
1N/A elsif (! defined($a) && defined($x)) {
1N/A ctrlfix(my $msg = "expected <$x>, got UNDEF");
1N/A print "not ok $N \# $msg\n";
1N/A } elsif ($a eq $x) { print "ok $N\n" }
1N/A else {
1N/A ctrlfix(my $msg = "expected <$x>, got <$a>");
1N/A print "not ok $N \# $msg\n";
1N/A }
1N/A } else {
1N/A die "expect() got ", scalar(@_), " args, should have been 1 or 2";
1N/A }
1N/A $N++;
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/AEND {
1N/A undef $o;
1N/A untie @a;
1N/A 1 while unlink $file;
1N/A}
1N/A