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