1#!/usr/bin/perl 2 3my $file = "tf09-$$.txt"; 4 5print "1..59\n"; 6 7use Fcntl 'O_RDONLY'; 8 9my $N = 1; 10use Tie::File; 11print "ok $N\n"; $N++; 12 13$RECSEP = 'blah'; 14my $o = tie @a, 'Tie::File', $file, 15 recsep => $RECSEP, autochomp => 0, autodefer => 0; 16print $o ? "ok $N\n" : "not ok $N\n"; 17$N++; 18 19 20# 3-4 create 21$a[0] = 'rec0'; 22check_contents("rec0"); 23 24# 5-8 append 25$a[1] = 'rec1'; 26check_contents("rec0", "rec1"); 27$a[2] = 'rec2'; 28check_contents("rec0", "rec1", "rec2"); 29 30# 9-14 same-length alterations 31$a[0] = 'new0'; 32check_contents("new0", "rec1", "rec2"); 33$a[1] = 'new1'; 34check_contents("new0", "new1", "rec2"); 35$a[2] = 'new2'; 36check_contents("new0", "new1", "new2"); 37 38# 15-24 lengthening alterations 39$a[0] = 'long0'; 40check_contents("long0", "new1", "new2"); 41$a[1] = 'long1'; 42check_contents("long0", "long1", "new2"); 43$a[2] = 'long2'; 44check_contents("long0", "long1", "long2"); 45$a[1] = 'longer1'; 46check_contents("long0", "longer1", "long2"); 47$a[0] = 'longer0'; 48check_contents("longer0", "longer1", "long2"); 49 50# 25-34 shortening alterations, including truncation 51$a[0] = 'short0'; 52check_contents("short0", "longer1", "long2"); 53$a[1] = 'short1'; 54check_contents("short0", "short1", "long2"); 55$a[2] = 'short2'; 56check_contents("short0", "short1", "short2"); 57$a[1] = 'sh1'; 58check_contents("short0", "sh1", "short2"); 59$a[0] = 'sh0'; 60check_contents("sh0", "sh1", "short2"); 61 62# (35-38) file with holes 63$a[4] = 'rec4'; 64check_contents("sh0", "sh1", "short2", "", "rec4"); 65$a[3] = 'rec3'; 66check_contents("sh0", "sh1", "short2", "rec3", "rec4"); 67 68# (39-40) zero out file 69@a = (); 70check_contents(); 71 72# (41-42) insert into the middle of an empty file 73$a[3] = "rec3"; 74check_contents("", "", "", "rec3"); 75 76# (43-47) 20020326 You thought there would be a bug in STORE where if 77# a cached record was false, STORE wouldn't see it at all. Yup, there is, 78# and adding the appropriate defined() test fixes the problem. 79undef $o; untie @a; 1 while unlink $file; 80$RECSEP = '0'; 81$o = tie @a, 'Tie::File', $file, 82 recsep => $RECSEP, autochomp => 0, autodefer => 0; 83print $o ? "ok $N\n" : "not ok $N\n"; 84$N++; 85$#a = 2; 86my $z = $a[1]; # caches "0" 87$a[2] = "oops"; 88check_contents("", "", "oops"); 89$a[1] = "bah"; 90check_contents("", "bah", "oops"); 91undef $o; untie @a; 92 93# (48-56) 20020331 Make sure we correctly handle the case where the final 94# record of the file is not properly terminated, Through version 0.90, 95# we would mangle the file. 96my $badrec = "Malformed"; 97$: = $RECSEP = Tie::File::_default_recsep(); 98# (48-50) 99if (setup_badly_terminated_file(3)) { 100 $o = tie @a, 'Tie::File', $file, 101 recsep => $RECSEP, autochomp => 0, autodefer => 0 102 or die "Couldn't tie file: $!"; 103 my $z = $a[0]; 104 print $z eq "$badrec$:" ? "ok $N\n" : 105 "not ok $N \# got $z, expected $badrec\n"; 106 $N++; 107 push @a, "next"; 108 check_contents($badrec, "next"); 109} 110# (51-52) 111if (setup_badly_terminated_file(2)) { 112 $o = tie @a, 'Tie::File', $file, 113 recsep => $RECSEP, autochomp => 0, autodefer => 0 114 or die "Couldn't tie file: $!"; 115 splice @a, 1, 0, "x", "y"; 116 check_contents($badrec, "x", "y"); 117} 118# (53-56) 119if (setup_badly_terminated_file(4)) { 120 $o = tie @a, 'Tie::File', $file, 121 recsep => $RECSEP, autochomp => 0, autodefer => 0 122 or die "Couldn't tie file: $!"; 123 my @r = splice @a, 0, 1, "x", "y"; 124 my $n = @r; 125 print $n == 1 ? "ok $N\n" : "not ok $N \# expected 1 elt, got $n\n"; 126 $N++; 127 print $r[0] eq "$badrec$:" ? "ok $N\n" 128 : "not ok $N \# expected <$badrec>, got <$r[0]>\n"; 129 $N++; 130 check_contents("x", "y"); 131} 132 133# (57-58) 20020402 The modification would have failed if $\ were set wrong. 134# I hate $\. 135if (setup_badly_terminated_file(2)) { 136 $o = tie @a, 'Tie::File', $file, 137 recsep => $RECSEP, autochomp => 0, autodefer => 0 138 or die "Couldn't tie file: $!"; 139 { local $\ = "I hate \$\\."; 140 my $z = $a[0]; 141 } 142 check_contents($badrec); 143} 144 145# (59) 20030527 Tom Christiansen pointed out that FETCH returns the wrong 146# data on the final record of an unterminated file if the file is opened 147# in read-only mode. Note that the $#a is necessary here. 148# There's special-case code to fix the final record when it is read normally. 149# But the $#a forces it to be read from the cache, which skips the 150# termination. 151$badrec = "world${RECSEP}hello"; 152if (setup_badly_terminated_file(1)) { 153 tie(@a, "Tie::File", $file, mode => O_RDONLY, recsep => $RECSEP) 154 or die "Couldn't tie file: $!"; 155 my $z = $#a; 156 $z = $a[1]; 157 print $z eq "hello" ? "ok $N\n" : 158 "not ok $N \# got $z, expected hello\n"; 159 $N++; 160} 161 162sub setup_badly_terminated_file { 163 my $NTESTS = shift; 164 open F, '>', $file or die "Couldn't open $file: $!"; 165 binmode F; 166 print F $badrec; 167 close F; 168 unless (-s $file == length $badrec) { 169 for (1 .. $NTESTS) { 170 print "ok $N \# skipped - can't create improperly terminated file\n"; 171 $N++; 172 } 173 return; 174 } 175 return 1; 176} 177 178 179use POSIX 'SEEK_SET'; 180sub check_contents { 181 my @c = @_; 182 my $x = join $RECSEP, @c, ''; 183 local *FH = $o->{fh}; 184 seek FH, 0, SEEK_SET; 185 my $a; 186 { local $/; $a = <FH> } 187 188 $a = "" unless defined $a; 189 if ($a eq $x) { 190 print "ok $N\n"; 191 } else { 192 my $msg = "# expected <$x>, got <$a>"; 193 ctrlfix($msg); 194 print "not ok $N $msg\n"; 195 } 196 $N++; 197 198 # now check FETCH: 199 my $good = 1; 200 for (0.. $#c) { 201 unless ($a[$_] eq "$c[$_]$RECSEP") { 202 $msg = "expected $c[$_]$RECSEP, got $a[$_]"; 203 ctrlfix($msg); 204 $good = 0; 205 } 206 } 207 print $good ? "ok $N\n" : "not ok $N # fetch $msg\n"; 208 $N++; 209} 210 211 212sub ctrlfix { 213 for (@_) { 214 s/\n/\\n/g; 215 s/\r/\\r/g; 216 } 217} 218 219 220END { 221 undef $o; 222 untie @a; 223 1 while unlink $file; 224} 225 226