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