1#!/usr/bin/perl 2 3use strict; 4use warnings; 5 6$| = 1; 7my $file = "tf01-$$.txt"; 81 while unlink $file; 9 10print "1..75\n"; 11 12my $N = 1; 13use Tie::File; 14print "ok $N\n"; $N++; 15 16my @a; 17my $o = tie @a, 'Tie::File', $file, autochomp => 0, autodefer => 0; 18print $o ? "ok $N\n" : "not ok $N\n"; 19$N++; 20 21$: = $o->{recsep}; 22 23# 3-5 create 24$a[0] = 'rec0'; 25check_contents("rec0"); 26 27# 6-11 append 28$a[1] = 'rec1'; 29check_contents("rec0", "rec1"); 30$a[2] = 'rec2'; 31check_contents("rec0", "rec1", "rec2"); 32 33# 12-20 same-length alterations 34$a[0] = 'new0'; 35check_contents("new0", "rec1", "rec2"); 36$a[1] = 'new1'; 37check_contents("new0", "new1", "rec2"); 38$a[2] = 'new2'; 39check_contents("new0", "new1", "new2"); 40 41# 21-35 lengthening alterations 42$a[0] = 'long0'; 43check_contents("long0", "new1", "new2"); 44$a[1] = 'long1'; 45check_contents("long0", "long1", "new2"); 46$a[2] = 'long2'; 47check_contents("long0", "long1", "long2"); 48$a[1] = 'longer1'; 49check_contents("long0", "longer1", "long2"); 50$a[0] = 'longer0'; 51check_contents("longer0", "longer1", "long2"); 52 53# 36-50 shortening alterations, including truncation 54$a[0] = 'short0'; 55check_contents("short0", "longer1", "long2"); 56$a[1] = 'short1'; 57check_contents("short0", "short1", "long2"); 58$a[2] = 'short2'; 59check_contents("short0", "short1", "short2"); 60$a[1] = 'sh1'; 61check_contents("short0", "sh1", "short2"); 62$a[0] = 'sh0'; 63check_contents("sh0", "sh1", "short2"); 64 65# (51-56) file with holes 66$a[4] = 'rec4'; 67check_contents("sh0", "sh1", "short2", "", "rec4"); 68$a[3] = 'rec3'; 69check_contents("sh0", "sh1", "short2", "rec3", "rec4"); 70 71# (57-59) zero out file 72@a = (); 73check_contents(); 74 75# (60-62) insert into the middle of an empty file 76$a[3] = "rec3"; 77check_contents("", "", "", "rec3"); 78 79# (63-68) 20020326 You thought there would be a bug in STORE where if 80# a cached record was false, STORE wouldn't see it at all. But you 81# forgot that records always come back from the cache with the record 82# separator attached, so they are unlikely to be false. The only 83# really weird case is when the cached record is empty and the record 84# separator is "0". Test that in 09_gen_rs.t. 85$a[1] = "0"; 86check_contents("", "0", "", "rec3"); 87$a[1] = "whoops"; 88check_contents("", "whoops", "", "rec3"); 89 90# (69-72) make sure that undefs are treated correctly---they should 91# be converted to empty records, and should not raise any warnings. 92# (Some of these failed in 0.90. The change to _fixrec fixed them.) 93# 20020331 94{ 95 my $good = 1; my $warn; 96 # If any of these raise warnings, we have a problem. 97 local $SIG{__WARN__} = sub { $good = 0; $warn = shift(); ctrlfix($warn)}; 98 local $^W = 1; 99 @a = (1); 100 $a[0] = undef; 101 print $good ? "ok $N\n" : "not ok $N # $warn\n"; 102 $N++; $good = 1; 103 print defined($a[0]) ? "ok $N\n" : "not ok $N\n"; 104 $N++; $good = 1; 105 $a[3] = '3'; 106 print defined($a[1]) ? "ok $N\n" : "not ok $N\n"; 107 $N++; $good = 1; 108 undef $a[3]; 109 print $good ? "ok $N\n" : "not ok $N # $warn\n"; 110 $N++; $good = 1; 111} 112 113# (73-75) What if the user has tampered with $\ ? 114{ { local $\ = "stop messing with the funny variables!"; 115 @a = (0..2); 116 } 117 check_contents(0..2); 118} 119 120use POSIX 'SEEK_SET'; 121sub check_contents { 122 my @c = @_; 123 my $x = join $:, @c, ''; 124 local *FH = $o->{fh}; 125 seek FH, 0, SEEK_SET; 126# my $open = open FH, "<", $file; 127 my $a; 128 { local $/; $a = <FH> } 129 $a = "" unless defined $a; 130 if ($a eq $x) { 131 print "ok $N\n"; 132 } else { 133 ctrlfix($a, $x); 134 print "not ok $N\n# expected <$x>, got <$a>\n"; 135 } 136 $N++; 137 138 # now check FETCH: 139 my $good = 1; 140 my $msg; 141 for (0.. $#c) { 142 my $aa = $a[$_]; 143 unless ($aa eq "$c[$_]$:") { 144 $msg = "expected <$c[$_]$:>, got <$aa>"; 145 ctrlfix($msg); 146 $good = 0; 147 } 148 } 149 print $good ? "ok $N\n" : "not ok $N # $msg\n"; 150 $N++; 151 152 print $o->_check_integrity($file, $ENV{INTEGRITY}) 153 ? "ok $N\n" : "not ok $N\n"; 154 $N++; 155} 156 157sub ctrlfix { 158 for (@_) { 159 s/\n/\\n/g; 160 s/\r/\\r/g; 161 } 162} 163 164END { 165 undef $o; 166 untie @a; 167 1 while unlink $file; 168} 169 170