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