1#!/usr/bin/perl 2 3my $file = "tf22-$$.txt"; 4$: = Tie::File::_default_recsep(); 5 6print "1..71\n"; 7 8my $N = 1; 9use Tie::File; 10print "ok $N\n"; $N++; 11 12my $o = tie @a, 'Tie::File', $file, autochomp => 1, autodefer => 0; 13print $o ? "ok $N\n" : "not ok $N\n"; 14$N++; 15 16# 3-5 create 17$a[0] = 'rec0'; 18check_contents("rec0"); 19 20# 6-11 append 21$a[1] = 'rec1'; 22check_contents("rec0", "rec1"); 23$a[2] = 'rec2'; 24check_contents("rec0", "rec1", "rec2"); 25 26# 12-20 same-length alterations 27$a[0] = 'new0'; 28check_contents("new0", "rec1", "rec2"); 29$a[1] = 'new1'; 30check_contents("new0", "new1", "rec2"); 31$a[2] = 'new2'; 32check_contents("new0", "new1", "new2"); 33 34# 21-35 lengthening alterations 35$a[0] = 'long0'; 36check_contents("long0", "new1", "new2"); 37$a[1] = 'long1'; 38check_contents("long0", "long1", "new2"); 39$a[2] = 'long2'; 40check_contents("long0", "long1", "long2"); 41$a[1] = 'longer1'; 42check_contents("long0", "longer1", "long2"); 43$a[0] = 'longer0'; 44check_contents("longer0", "longer1", "long2"); 45 46# 36-50 shortening alterations, including truncation 47$a[0] = 'short0'; 48check_contents("short0", "longer1", "long2"); 49$a[1] = 'short1'; 50check_contents("short0", "short1", "long2"); 51$a[2] = 'short2'; 52check_contents("short0", "short1", "short2"); 53$a[1] = 'sh1'; 54check_contents("short0", "sh1", "short2"); 55$a[0] = 'sh0'; 56check_contents("sh0", "sh1", "short2"); 57 58# (51-56) file with holes 59$a[4] = 'rec4'; 60check_contents("sh0", "sh1", "short2", "", "rec4"); 61$a[3] = 'rec3'; 62check_contents("sh0", "sh1", "short2", "rec3", "rec4"); 63 64# (57-59) zero out file 65@a = (); 66check_contents(); 67 68# (60-62) insert into the middle of an empty file 69$a[3] = "rec3"; 70check_contents("", "", "", "rec3"); 71 72# (63-68) Test the ->autochomp() method 73@a = qw(Gold Frankincense Myrrh); 74my $ac; 75$ac = $o->autochomp(); 76expect($ac); 77# See if that accidentally changed it 78$ac = $o->autochomp(); 79expect($ac); 80# Now clear it 81$ac = $o->autochomp(0); 82expect($ac); 83expect(join("-", @a), "Gold$:-Frankincense$:-Myrrh$:"); 84# Now set it again 85$ac = $o->autochomp(1); 86expect(!$ac); 87expect(join("-", @a), "Gold-Frankincense-Myrrh"); 88 89# (69) Does 'splice' work correctly with autochomp? 90my @sr; 91@sr = splice @a, 0, 2; 92expect(join("-", @sr), "Gold-Frankincense"); 93 94# (70-71) Didn't you forget that fetch may return an unchomped cached record? 95$a1 = $a[0]; # populate cache 96$a2 = $a[0]; 97expect($a1, "Myrrh"); 98expect($a2, "Myrrh"); 99# Actually no, you didn't---_fetch might return such a record, but 100# the chomping is done by FETCH. 101 102use POSIX 'SEEK_SET'; 103sub check_contents { 104 my @c = @_; 105 my $x = join $:, @c, ''; 106 local *FH = $o->{fh}; 107 seek FH, 0, SEEK_SET; 108# my $open = open FH, '<', $file; 109 my $a; 110 { local $/; $a = <FH> } 111 $a = "" unless defined $a; 112 if ($a eq $x) { 113 print "ok $N\n"; 114 } else { 115 ctrlfix($a, $x); 116 print "not ok $N\n# expected <$x>, got <$a>\n"; 117 } 118 $N++; 119 120 # now check FETCH: 121 my $good = 1; 122 my $msg; 123 for (0.. $#c) { 124 my $aa = $a[$_]; 125 unless ($aa eq $c[$_]) { 126 $msg = "expected <$c[$_]>, got <$aa>"; 127 ctrlfix($msg); 128 $good = 0; 129 } 130 } 131 print $good ? "ok $N\n" : "not ok $N # $msg\n"; 132 $N++; 133 134 print $o->_check_integrity($file, $ENV{INTEGRITY}) 135 ? "ok $N\n" : "not ok $N\n"; 136 $N++; 137} 138 139sub expect { 140 if (@_ == 1) { 141 print $_[0] ? "ok $N\n" : "not ok $N\n"; 142 } elsif (@_ == 2) { 143 my ($a, $x) = @_; 144 if (! defined($a) && ! defined($x)) { print "ok $N\n" } 145 elsif ( defined($a) && ! defined($x)) { 146 ctrlfix(my $msg = "expected UNDEF, got <$a>"); 147 print "not ok $N \# $msg\n"; 148 } 149 elsif (! defined($a) && defined($x)) { 150 ctrlfix(my $msg = "expected <$x>, got UNDEF"); 151 print "not ok $N \# $msg\n"; 152 } elsif ($a eq $x) { print "ok $N\n" } 153 else { 154 ctrlfix(my $msg = "expected <$x>, got <$a>"); 155 print "not ok $N \# $msg\n"; 156 } 157 } else { 158 die "expect() got ", scalar(@_), " args, should have been 1 or 2"; 159 } 160 $N++; 161} 162 163sub ctrlfix { 164 for (@_) { 165 s/\n/\\n/g; 166 s/\r/\\r/g; 167 } 168} 169 170END { 171 undef $o; 172 untie @a; 173 1 while unlink $file; 174} 175 176