1#!/usr/bin/perl
2
3$| = 1;
4my $file = "tf01-$$.txt";
51 while unlink $file;
6
7print "1..75\n";
8
9my $N = 1;
10use Tie::File;
11print "ok $N\n"; $N++;
12
13my $o = tie @a, 'Tie::File', $file, autochomp => 0, autodefer => 0;
14print $o ? "ok $N\n" : "not ok $N\n";
15$N++;
16
17$: = $o->{recsep};
18
19# 3-5 create
20$a[0] = 'rec0';
21check_contents("rec0");
22
23# 6-11 append
24$a[1] = 'rec1';
25check_contents("rec0", "rec1");
26$a[2] = 'rec2';
27check_contents("rec0", "rec1", "rec2");
28
29# 12-20 same-length alterations
30$a[0] = 'new0';
31check_contents("new0", "rec1", "rec2");
32$a[1] = 'new1';
33check_contents("new0", "new1", "rec2");
34$a[2] = 'new2';
35check_contents("new0", "new1", "new2");
36
37# 21-35 lengthening alterations
38$a[0] = 'long0';
39check_contents("long0", "new1", "new2");
40$a[1] = 'long1';
41check_contents("long0", "long1", "new2");
42$a[2] = 'long2';
43check_contents("long0", "long1", "long2");
44$a[1] = 'longer1';
45check_contents("long0", "longer1", "long2");
46$a[0] = 'longer0';
47check_contents("longer0", "longer1", "long2");
48
49# 36-50 shortening alterations, including truncation
50$a[0] = 'short0';
51check_contents("short0", "longer1", "long2");
52$a[1] = 'short1';
53check_contents("short0", "short1", "long2");
54$a[2] = 'short2';
55check_contents("short0", "short1", "short2");
56$a[1] = 'sh1';
57check_contents("short0", "sh1", "short2");
58$a[0] = 'sh0';
59check_contents("sh0", "sh1", "short2");
60
61# (51-56) file with holes
62$a[4] = 'rec4';
63check_contents("sh0", "sh1", "short2", "", "rec4");
64$a[3] = 'rec3';
65check_contents("sh0", "sh1", "short2", "rec3", "rec4");
66
67# (57-59) zero out file
68@a = ();
69check_contents();
70
71# (60-62) insert into the middle of an empty file
72$a[3] = "rec3";
73check_contents("", "", "", "rec3");
74
75# (63-68) 20020326 You thought there would be a bug in STORE where if
76# a cached record was false, STORE wouldn't see it at all.  But you
77# forgot that records always come back from the cache with the record
78# separator attached, so they are unlikely to be false.  The only
79# really weird case is when the cached record is empty and the record
80# separator is "0".  Test that in 09_gen_rs.t.
81$a[1] = "0";
82check_contents("", "0", "", "rec3");
83$a[1] = "whoops";
84check_contents("", "whoops", "", "rec3");
85
86# (69-72) make sure that undefs are treated correctly---they should
87# be converted to empty records, and should not raise any warnings.
88# (Some of these failed in 0.90.  The change to _fixrec fixed them.)
89# 20020331
90{
91  my $good = 1; my $warn;
92  # If any of these raise warnings, we have a problem.
93  local $SIG{__WARN__} = sub { $good = 0; $warn = shift(); ctrlfix($warn)};
94  local $^W = 1;
95  @a = (1);
96  $a[0] = undef;
97  print $good ? "ok $N\n" : "not ok $N # $warn\n";
98  $N++; $good = 1;
99  print defined($a[0]) ? "ok $N\n" : "not ok $N\n";
100  $N++; $good = 1;
101  $a[3] = '3';
102  print defined($a[1]) ? "ok $N\n" : "not ok $N\n";
103  $N++; $good = 1;
104  undef $a[3];
105  print $good ? "ok $N\n" : "not ok $N # $warn\n";
106  $N++; $good = 1;
107}
108
109# (73-75) What if the user has tampered with $\ ?
110{ {  local $\ = "stop messing with the funny variables!";
111     @a = (0..2);
112   }
113  check_contents(0..2);
114}
115
116use POSIX 'SEEK_SET';
117sub check_contents {
118  my @c = @_;
119  my $x = join $:, @c, '';
120  local *FH = $o->{fh};
121  seek FH, 0, SEEK_SET;
122#  my $open = open FH, "<", $file;
123  my $a;
124  { local $/; $a = <FH> }
125  $a = "" unless defined $a;
126  if ($a eq $x) {
127    print "ok $N\n";
128  } else {
129    ctrlfix($a, $x);
130    print "not ok $N\n# expected <$x>, got <$a>\n";
131  }
132  $N++;
133
134  # now check FETCH:
135  my $good = 1;
136  my $msg;
137  for (0.. $#c) {
138    my $aa = $a[$_];
139    unless ($aa eq "$c[$_]$:") {
140      $msg = "expected <$c[$_]$:>, got <$aa>";
141      ctrlfix($msg);
142      $good = 0;
143    }
144  }
145  print $good ? "ok $N\n" : "not ok $N # $msg\n";
146  $N++;
147
148  print $o->_check_integrity($file, $ENV{INTEGRITY})
149      ? "ok $N\n" : "not ok $N\n";
150  $N++;
151}
152
153sub ctrlfix {
154  for (@_) {
155    s/\n/\\n/g;
156    s/\r/\\r/g;
157  }
158}
159
160END {
161  undef $o;
162  untie @a;
163  1 while unlink $file;
164}
165
166