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