1#!/usr/bin/perl
2
3use strict;
4use warnings;
5
6my $file = "tf22-$$.txt";
7$: = Tie::File::_default_recsep();
8
9print "1..71\n";
10
11my $N = 1;
12use Tie::File;
13print "ok $N\n"; $N++;
14
15my @a;
16my $o = tie @a, 'Tie::File', $file, autochomp => 1, autodefer => 0;
17print $o ? "ok $N\n" : "not ok $N\n";
18$N++;
19
20# 3-5 create
21$a[0] = 'rec0';
22check_contents("rec0");
23
24# 6-11 append
25$a[1] = 'rec1';
26check_contents("rec0", "rec1");
27$a[2] = 'rec2';
28check_contents("rec0", "rec1", "rec2");
29
30# 12-20 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# 21-35 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# 36-50 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# (51-56) 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# (57-59) zero out file
69@a = ();
70check_contents();
71
72# (60-62) insert into the middle of an empty file
73$a[3] = "rec3";
74check_contents("", "", "", "rec3");
75
76# (63-68) Test the ->autochomp() method
77@a = qw(Gold Frankincense Myrrh);
78my $ac;
79$ac = $o->autochomp();
80expect($ac);
81# See if that accidentally changed it
82$ac = $o->autochomp();
83expect($ac);
84# Now clear it
85$ac = $o->autochomp(0);
86expect($ac);
87expect(join("-", @a), "Gold$:-Frankincense$:-Myrrh$:");
88# Now set it again
89$ac = $o->autochomp(1);
90expect(!$ac);
91expect(join("-", @a), "Gold-Frankincense-Myrrh");
92
93# (69) Does 'splice' work correctly with autochomp?
94my @sr;
95@sr = splice @a, 0, 2;
96expect(join("-", @sr), "Gold-Frankincense");
97
98# (70-71) Didn't you forget that fetch may return an unchomped cached record?
99my $a1 = $a[0];                    # populate cache
100my $a2 = $a[0];
101expect($a1, "Myrrh");
102expect($a2, "Myrrh");
103# Actually no, you didn't---_fetch might return such a record, but
104# the chomping is done by FETCH.
105
106use POSIX 'SEEK_SET';
107sub check_contents {
108  my @c = @_;
109  my $x = join $:, @c, '';
110  local *FH = $o->{fh};
111  seek FH, 0, SEEK_SET;
112#  my $open = open FH, '<', $file;
113  my $a;
114  { local $/; $a = <FH> }
115  $a = "" unless defined $a;
116  if ($a eq $x) {
117    print "ok $N\n";
118  } else {
119    ctrlfix($a, $x);
120    print "not ok $N\n# expected <$x>, got <$a>\n";
121  }
122  $N++;
123
124  # now check FETCH:
125  my $good = 1;
126  my $msg;
127  for (0.. $#c) {
128    my $aa = $a[$_];
129    unless ($aa eq $c[$_]) {
130      $msg = "expected <$c[$_]>, got <$aa>";
131      ctrlfix($msg);
132      $good = 0;
133    }
134  }
135  print $good ? "ok $N\n" : "not ok $N # $msg\n";
136  $N++;
137
138  print $o->_check_integrity($file, $ENV{INTEGRITY})
139      ? "ok $N\n" : "not ok $N\n";
140  $N++;
141}
142
143sub expect {
144  if (@_ == 1) {
145    print $_[0] ? "ok $N\n" : "not ok $N\n";
146  } elsif (@_ == 2) {
147    my ($a, $x) = @_;
148    if    (! defined($a) && ! defined($x)) { print "ok $N\n" }
149    elsif (  defined($a) && ! defined($x)) {
150      ctrlfix(my $msg = "expected UNDEF, got <$a>");
151      print "not ok $N \# $msg\n";
152    }
153    elsif (! defined($a) &&   defined($x)) {
154      ctrlfix(my $msg = "expected <$x>, got UNDEF");
155      print "not ok $N \# $msg\n";
156    } elsif ($a eq $x) { print "ok $N\n" }
157    else {
158      ctrlfix(my $msg = "expected <$x>, got <$a>");
159      print "not ok $N \# $msg\n";
160    }
161  } else {
162    die "expect() got ", scalar(@_), " args, should have been 1 or 2";
163  }
164  $N++;
165}
166
167sub ctrlfix {
168  for (@_) {
169    s/\n/\\n/g;
170    s/\r/\\r/g;
171  }
172}
173
174END {
175  undef $o;
176  untie @a;
177  1 while unlink $file;
178}
179
180