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