Commit | Line | Data |
b5aed31e |
1 | #!/usr/bin/perl |
2 | |
3 | my $file = "tf$$.txt"; |
4 | |
29aee836 |
5 | print "1..59\n"; |
b5aed31e |
6 | |
cf0d1c66 |
7 | use Fcntl 'O_RDONLY'; |
8 | |
b5aed31e |
9 | my $N = 1; |
10 | use Tie::File; |
11 | print "ok $N\n"; $N++; |
12 | |
6fc0ea7e |
13 | $RECSEP = 'blah'; |
14 | my $o = tie @a, 'Tie::File', $file, |
15 | recsep => $RECSEP, autochomp => 0, autodefer => 0; |
b5aed31e |
16 | print $o ? "ok $N\n" : "not ok $N\n"; |
17 | $N++; |
18 | |
19 | |
20 | # 3-4 create |
21 | $a[0] = 'rec0'; |
22 | check_contents("rec0"); |
23 | |
24 | # 5-8 append |
25 | $a[1] = 'rec1'; |
26 | check_contents("rec0", "rec1"); |
27 | $a[2] = 'rec2'; |
28 | check_contents("rec0", "rec1", "rec2"); |
29 | |
30 | # 9-14 same-length alterations |
31 | $a[0] = 'new0'; |
32 | check_contents("new0", "rec1", "rec2"); |
33 | $a[1] = 'new1'; |
34 | check_contents("new0", "new1", "rec2"); |
35 | $a[2] = 'new2'; |
36 | check_contents("new0", "new1", "new2"); |
37 | |
38 | # 15-24 lengthening alterations |
39 | $a[0] = 'long0'; |
40 | check_contents("long0", "new1", "new2"); |
41 | $a[1] = 'long1'; |
42 | check_contents("long0", "long1", "new2"); |
43 | $a[2] = 'long2'; |
44 | check_contents("long0", "long1", "long2"); |
45 | $a[1] = 'longer1'; |
46 | check_contents("long0", "longer1", "long2"); |
47 | $a[0] = 'longer0'; |
48 | check_contents("longer0", "longer1", "long2"); |
49 | |
50 | # 25-34 shortening alterations, including truncation |
51 | $a[0] = 'short0'; |
52 | check_contents("short0", "longer1", "long2"); |
53 | $a[1] = 'short1'; |
54 | check_contents("short0", "short1", "long2"); |
55 | $a[2] = 'short2'; |
56 | check_contents("short0", "short1", "short2"); |
57 | $a[1] = 'sh1'; |
58 | check_contents("short0", "sh1", "short2"); |
59 | $a[0] = 'sh0'; |
60 | check_contents("sh0", "sh1", "short2"); |
61 | |
27531ffb |
62 | # (35-38) file with holes |
b5aed31e |
63 | $a[4] = 'rec4'; |
64 | check_contents("sh0", "sh1", "short2", "", "rec4"); |
65 | $a[3] = 'rec3'; |
66 | check_contents("sh0", "sh1", "short2", "rec3", "rec4"); |
67 | |
27531ffb |
68 | # (39-40) zero out file |
6fc0ea7e |
69 | @a = (); |
70 | check_contents(); |
71 | |
27531ffb |
72 | # (41-42) insert into the middle of an empty file |
6fc0ea7e |
73 | $a[3] = "rec3"; |
74 | check_contents("", "", "", "rec3"); |
75 | |
27531ffb |
76 | # (43-47) 20020326 You thought there would be a bug in STORE where if |
6fc0ea7e |
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. |
79 | undef $o; untie @a; 1 while unlink $file; |
80 | $RECSEP = '0'; |
81 | $o = tie @a, 'Tie::File', $file, |
82 | recsep => $RECSEP, autochomp => 0, autodefer => 0; |
83 | print $o ? "ok $N\n" : "not ok $N\n"; |
84 | $N++; |
85 | $#a = 2; |
86 | my $z = $a[1]; # caches "0" |
87 | $a[2] = "oops"; |
88 | check_contents("", "", "oops"); |
89 | $a[1] = "bah"; |
90 | check_contents("", "bah", "oops"); |
27531ffb |
91 | undef $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. |
96 | my $badrec = "Malformed"; |
97 | $: = $RECSEP = Tie::File::_default_recsep(); |
98 | # (48-50) |
99 | if (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) |
111 | if (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) |
119 | if (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 | |
29aee836 |
133 | # (57-58) 20020402 The modification would have failed if $\ were set wrong. |
bf919750 |
134 | # I hate $\. |
135 | if (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 | |
29aee836 |
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. |
cab02963 |
151 | $badrec = "world${RECSEP}hello"; |
29aee836 |
152 | if (setup_badly_terminated_file(1)) { |
cf0d1c66 |
153 | tie(@a, "Tie::File", $file, mode => O_RDONLY, recsep => $RECSEP) |
29aee836 |
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 | |
27531ffb |
162 | sub 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 | } |
b5aed31e |
177 | |
b5aed31e |
178 | |
7b6b3db1 |
179 | use POSIX 'SEEK_SET'; |
b5aed31e |
180 | sub check_contents { |
181 | my @c = @_; |
6fc0ea7e |
182 | my $x = join $RECSEP, @c, ''; |
7b6b3db1 |
183 | local *FH = $o->{fh}; |
184 | seek FH, 0, SEEK_SET; |
b5aed31e |
185 | my $a; |
186 | { local $/; $a = <FH> } |
7b6b3db1 |
187 | |
188 | $a = "" unless defined $a; |
189 | if ($a eq $x) { |
190 | print "ok $N\n"; |
191 | } else { |
b3fe5a4c |
192 | my $msg = "# expected <$x>, got <$a>"; |
193 | ctrlfix($msg); |
194 | print "not ok $N $msg\n"; |
7b6b3db1 |
195 | } |
b5aed31e |
196 | $N++; |
197 | |
198 | # now check FETCH: |
199 | my $good = 1; |
200 | for (0.. $#c) { |
6fc0ea7e |
201 | unless ($a[$_] eq "$c[$_]$RECSEP") { |
202 | $msg = "expected $c[$_]$RECSEP, got $a[$_]"; |
b3fe5a4c |
203 | ctrlfix($msg); |
7b6b3db1 |
204 | $good = 0; |
205 | } |
b5aed31e |
206 | } |
6fc0ea7e |
207 | print $good ? "ok $N\n" : "not ok $N # fetch $msg\n"; |
b5aed31e |
208 | $N++; |
209 | } |
210 | |
b3fe5a4c |
211 | |
212 | sub ctrlfix { |
213 | for (@_) { |
214 | s/\n/\\n/g; |
215 | s/\r/\\r/g; |
216 | } |
217 | } |
218 | |
219 | |
b5aed31e |
220 | END { |
7b6b3db1 |
221 | undef $o; |
222 | untie @a; |
b5aed31e |
223 | 1 while unlink $file; |
224 | } |
225 | |