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