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