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